pax_global_header00006660000000000000000000000064152261012530014507gustar00rootroot0000000000000052 comment=328f929492008e742619a4b1fc1643253aa1712c qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/000077500000000000000000000000001522610125300211125ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.editorconfig000066400000000000000000000007331522610125300235720ustar00rootroot00000000000000root = true [*] end_of_line = lf trim_trailing_whitespace = true charset = utf-8 [Makefile] indent_style = tab [*.{c,cpp,h,hpp,f,f90,F,F90}] indent_style = space indent_size = 4 insert_final_newline = true [*.{f,F}] max_line_length = 72 [*.{f90,f95,f03,F90,F95,F03}] max_line_length = 132 [*{c,cpp,h,hpp}] curly_bracket_next_line = true indent_brace_style = Allman [CMakeLists.txt] indent_style = space indent_size = 4 [*.cmake] indent_style = space indent_size = 4 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.github/000077500000000000000000000000001522610125300224525ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.github/workflows/000077500000000000000000000000001522610125300245075ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.github/workflows/build-coverage.yml000066400000000000000000000107641522610125300301320ustar00rootroot00000000000000name: Coverage Report on: push: branches: - master paths: - .github/workflows/*.yml - '**CMakeLists.txt' - 'cmake/**' - 'test/**' - 'src/**' - '!**md' pull_request: branches: - master paths: - .github/workflows/*.yml - '**CMakeLists.txt' - 'cmake/**' - 'test/**' - 'src/**' - '!**md' #env: # Customize the CMake build type here (Release, Debug, RelWithDebInfo, etc.) defaults: run: shell: bash jobs: coverage: name: Coverage Build # Use GNU compilers # The CMake configure and build commands are platform agnostic and should work equally # well on Windows or Mac. You can convert this to a matrix build if you need # cross-platform coverage. # See: https://docs.github.com/en/free-pro-team@latest/actions/learn-github-actions/managing-complex-workflows#using-a-build-matrix runs-on: ${{ matrix.os }} timeout-minutes: 5 env: BUILD_TYPE: Debug FFLAGS: ${{ matrix.fflags }} strategy: fail-fast: true matrix: os: [ ubuntu-latest ] fflags: [ "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -fimplicit-none -frecursive -fopenmp" ] # Better flags but not used by now: # "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -Werror=conversion -fimplicit-none -frecursive -fcheck=all", # "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -Werror=conversion -fimplicit-none -frecursive -fcheck=all -fopenmp" ] steps: - name: Checkout QR Update uses: actions/checkout@v7 - name: Install basics (Ubuntu) if: ${{ matrix.os == 'ubuntu-latest' }} run: | sudo apt update sudo apt install -y cmake liblapack-dev libblas-dev gcovr - name: Configure CMake # Configure CMake in a 'build' subdirectory. `CMAKE_BUILD_TYPE` is only required if you are using a single-configuration generator such as make. # See https://cmake.org/cmake/help/latest/variable/CMAKE_BUILD_TYPE.html?highlight=cmake_build_type run: > cmake -B build -G Ninja -D CMAKE_BUILD_TYPE=${{env.BUILD_TYPE}} -D CMAKE_INSTALL_PREFIX=${{github.workspace}}/lapack_install -D SLICOT_TESTING:BOOL=ON -D BUILD_SHARED_LIBS:BOOL=ON -D ENABLE_COVERAGE:BOOL=ON - name: Build working-directory: ${{github.workspace}}/build run: ninja - name: Test working-directory: ${{github.workspace}}/build run: ninja test - name: Collect coverage results working-directory: ${{github.workspace}}/build run: ninja gcov - name: Generate HTML Report uses: threeal/gcovr-action@v1.2.0 with: html-out: coverage.html xml-out: cobertura.xml coveralls-out: coveralls.json print-summary: true root: ${{github.workspace}} - name: Produce the coverage report uses: insightsengineering/coverage-action@v3 with: # Path to the Cobertura XML report. path: ./cobertura.xml # Minimum total coverage, if you want to the # workflow to enforce it as a standard. # This has no effect if the `fail` arg is set to `false`. threshold: 45.00 # Fail the workflow if the minimum code coverage # reuqirements are not satisfied. fail: true # Publish the rendered output as a PR comment publish: true exclude-detailed-coverage: true # Create a coverage diff report. diff: true # Branch to diff against. # Compare the current coverage to the coverage # determined on this branch. diff-branch: main # This is where the coverage reports for the # `diff-branch` are stored. # Branch is created if it doesn't already exist'. diff-storage: _xml_coverage_reports # A custom title that can be added to the code # coverage summary in the PR comment. coverage-summary-title: "Code Coverage Summary" # Failure modes for coverage regression detection: # Fail if any changed file has more uncovered lines (pycobertura exit code 2) uncovered-statements-increase-failure: false # Fail if new uncovered statements are introduced despite overall improvement (pycobertura exit code 3) new-uncovered-statements-failure: false # Fail if the overall coverage percentage decreases (more forgiving approach) coverage-rate-reduction-failure: true qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.github/workflows/build-msys2.yml000066400000000000000000000057031522610125300274110ustar00rootroot00000000000000name: Build on Windows with MSYS2 on: push: branches: - master - cmake_integration paths: - .github/workflows/*.yml - '**CMakeLists.txt' - 'cmake/**' - 'test/**' - 'src/**' - '!**Makefile' - '!**md' pull_request: paths: - .github/workflows/*.yml - '**CMakeLists.txt' - 'cmake/**' - 'test/**' - 'src/**' - '!**Makefile' - '!**md' permissions: contents: read jobs: test-install-release: runs-on: ${{ matrix.os.runs-on }} env: BUILD_TYPE: Release FFLAGS: ${{ matrix.fflags }} strategy: fail-fast: false matrix: fflags: - "-fimplicit-none " - "-fimplicit-none -fopenmp" os: # - { icon: '⬛', sys: mingw32, runs-on: 'windows-latest' } - { icon: '🟦', sys: mingw64, runs-on: 'windows-latest', fortran: 'gcc-fortran' } - { icon: '🟨', sys: ucrt64, runs-on: 'windows-latest', fortran: 'gcc-fortran' } - { icon: '🟧', sys: clang64, runs-on: 'windows-latest', fortran: 'flang' } - { icon: '🟩', sys: clangarm64, runs-on: 'windows-11-arm', fortran: 'flang' } name: 🚧${{ matrix.os.icon }} ${{ matrix.os.sys }} defaults: run: shell: msys2 {0} steps: - name: '🧰 Checkout QR Update' uses: actions/checkout@v7 with: fetch-depth: 0 persist-credentials: false - name: '${{ matrix.os.icon }} Setup MSYS2' uses: msys2/setup-msys2@v2 with: msystem: ${{matrix.os.sys}} update: true install: >- git make pacboy: >- ${{ matrix.os.fortran }} toolchain:p cmake:p ninja:p lapack:p - name: Configure CMake # Configure CMake in a 'build' subdirectory. `CMAKE_BUILD_TYPE` is only required if you are using a single-configuration generator such as make. # See https://cmake.org/cmake/help/latest/variable/CMAKE_BUILD_TYPE.html?highlight=cmake_build_type run: > cmake -B build -G Ninja -D CMAKE_BUILD_TYPE=${{env.BUILD_TYPE}} -D CMAKE_INSTALL_PREFIX=${{github.workspace}}/lapack_install -D SLICOT_TESTING:BOOL=ON -D BUILD_SHARED_LIBS:BOOL=${{ matrix.os.fortran == 'flang' && 'OFF' || 'ON' }} -D CMAKE_EXE_LINKER_FLAGS="-Wl,--stack=2097152" - name: '🚧 Build' run: | cmake --build build --config ${{env.BUILD_TYPE}} - name: Test with OpenMP working-directory: ${{github.workspace}}/build if: ${{ contains( matrix.fflags, 'openmp' ) }} run: ctest -C ${{env.BUILD_TYPE}} --schedule-random -j1 --output-on-failure --timeout 100 - name: Test working-directory: ${{github.workspace}}/build if: ${{ !contains( matrix.fflags, 'openmp' ) }} run: ctest -C ${{env.BUILD_TYPE}} --schedule-random -j2 --output-on-failure --timeout 100 - name: Install run: cmake --build build --target install -j2 # qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.github/workflows/build-unix.yml000066400000000000000000000072311522610125300273150ustar00rootroot00000000000000name: Build on Unix on: push: branches: - master - cmake_integration paths: - .github/workflows/*.yml - '**CMakeLists.txt' - 'cmake/**' - 'test/**' - 'src/**' - '!**md' pull_request: paths: - .github/workflows/*.yml - '**CMakeLists.txt' - 'cmake/**' - 'test/**' - 'src/**' - '!**md' permissions: contents: read #env: # Customize the CMake build type here (Release, Debug, RelWithDebInfo, etc.) defaults: run: shell: bash jobs: test-install-release: # Use GNU compilers # The CMake configure and build commands are platform agnostic and should work equally # well on Windows or Mac. You can convert this to a matrix build if you need # cross-platform coverage. # See: https://docs.github.com/en/free-pro-team@latest/actions/learn-github-actions/managing-complex-workflows#using-a-build-matrix runs-on: ${{ matrix.os }} timeout-minutes: 5 env: BUILD_TYPE: Release FFLAGS: ${{ matrix.fflags }} strategy: fail-fast: true matrix: os: [ macos-latest, ubuntu-latest ] fflags: [ "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -fimplicit-none -frecursive ", "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -fimplicit-none -frecursive -fopenmp" ] # Better flags but not used by now: # "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -Werror=conversion -fimplicit-none -frecursive -fcheck=all", # "-Wall -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label -Werror=conversion -fimplicit-none -frecursive -fcheck=all -fopenmp" ] steps: - name: Checkout QR Update uses: actions/checkout@v7 - name: Install basics (Ubuntu) if: ${{ matrix.os == 'ubuntu-latest' }} run: | sudo apt update sudo apt install -y cmake liblapack-dev libblas-dev - name: Install basics (MacOS) if: ${{ matrix.os == 'macos-latest' }} run: | brew install openblas - name: Use GCC on MacOS if: ${{ matrix.os == 'macos-latest' }} run: > cmake -B build -G Ninja -D CMAKE_C_COMPILER="gcc" -D CMAKE_Fortran_COMPILER="gfortran" -D CMAKE_PREFIX_PATH="/opt/homebrew/opt/openblas" -D CMAKE_INSTALL_PREFIX=${{github.workspace}}/lapack_install -D BLA_VENDOR=OpenBLAS - name: Configure CMake # Configure CMake in a 'build' subdirectory. `CMAKE_BUILD_TYPE` is only required if you are using a single-configuration generator such as make. # See https://cmake.org/cmake/help/latest/variable/CMAKE_BUILD_TYPE.html?highlight=cmake_build_type if: ${{ matrix.os == 'ubuntu-latest' }} run: > cmake -B build -G Ninja -D CMAKE_BUILD_TYPE=${{env.BUILD_TYPE}} -D CMAKE_INSTALL_PREFIX=${{github.workspace}}/lapack_install -D BUILD_SHARED_LIBS:BOOL=ON - name: Build # Execute tests defined by the CMake configuration. # See https://cmake.org/cmake/help/latest/manual/ctest.1.html for more detail run: cmake --build build --config ${{env.BUILD_TYPE}} - name: Test with OpenMP working-directory: ${{github.workspace}}/build if: ${{ contains( matrix.fflags, 'openmp' ) }} run: ctest -C ${{env.BUILD_TYPE}} --schedule-random -j1 --output-on-failure --timeout 100 - name: Test working-directory: ${{github.workspace}}/build if: ${{ !contains( matrix.fflags, 'openmp' ) }} run: ctest -C ${{env.BUILD_TYPE}} --schedule-random -j2 --output-on-failure --timeout 100 - name: Install run: cmake --build build --target install -j2 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitignore000066400000000000000000000000251522610125300230770ustar00rootroot00000000000000build* *.swp *.tar.* qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab-ci.yml000066400000000000000000000061231522610125300235500ustar00rootroot00000000000000stages: - build build-ubuntu: parallel: matrix: - UBUNTU_VERSION: [ "jammy", "noble", "resolute" ] stage: build image: ${CI_REGISTRY_IMAGE}/ubuntu:${UBUNTU_VERSION} script: - mkdir -p build - cd build - cmake ../ -DDEBUG=ON - make - ctest -V build-ubuntu-fpm: parallel: matrix: - UBUNTU_VERSION: [ "jammy", "noble", "resolute" ] stage: build image: ${CI_REGISTRY_IMAGE}/ubuntu:${UBUNTU_VERSION} script: - fpm build - fpm test build-almalinux: tags: - haswell parallel: matrix: - ALMA_VERSION: ["8", "9", "10" ] stage: build image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/almalinux:${ALMA_VERSION} script: - dnf install -y blas-devel lapack-devel - if [ ${ALMA_VERSION} -eq 9 ]; then (cd /usr/lib64/; ln -sf libblas.so.3.9.0 libblas.so.3; ln -sf liblapack.so.3.9.0 liblapack.so.3 ); fi - mkdir -p build - cd build - cmake ../ -DDEBUG=ON - make - ctest -V build-fedora: parallel: matrix: - FEDORA_VERSION: ["42", "43", "44" ] stage: build image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/fedora:${FEDORA_VERSION} script: - dnf install -y flexiblas-devel - mkdir -p build - cd build - cmake ../ -DDEBUG=ON - make - ctest -V build-aocc: parallel: matrix: - AOCC_VERSION: [ "5.1.0", "5.2.0" ] stage: build needs: [] image: gitlab.mpi-magdeburg.mpg.de/ci-images/aocc-compiler/noble:${AOCC_VERSION} script: - apt update && apt install --yes libopenblas-dev libblas-dev liblapack-dev - mkdir -p build - cd build - cmake ../ -DDEBUG=ON - make # We do not run the test with AOCC since the compiler produces invalid results # - ctest -V build-intel: parallel: matrix: - INTEL_VERSION: [ "2024", "2025", "2026" ] stage: build needs: [] image: gitlab.mpi-magdeburg.mpg.de/ci-images/intel-compiler/noble:${INTEL_VERSION} script: - mkdir -p build - cd build - CC=icx FC=ifx cmake ../ -DDEBUG=ON -DBLA_VENDOR=Intel10_64lp - make - ctest -V coverage: image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/ubuntu:noble stage: build needs: [] script: - apt update && apt-get install --yes --no-install-recommends lcov gcovr libopenblas-dev libblas-dev liblapack-dev - cmake -S . -B build-dir -DCMAKE_BUILD_TYPE=Debug -DENABLE_COVERAGE=ON - cmake --build build-dir - cd build-dir - make - OMP_NUM_THREADS=1 make test - make gcov - gcovr -r .. coverage: '/^TOTAL.*\s+(\d+\%)$/' cross-win32: stage: build image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/mingw:focal script: - bash ./tools/ci/cross-win32.sh cross-win64: stage: build image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/mingw:focal script: - bash ./tools/ci/cross-win64.sh cross-win32-jammy: stage: build image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/mingw:jammy script: - bash ./tools/ci/cross-win32.sh cross-win64-jammy: stage: build image: gitlab.mpi-magdeburg.mpg.de/ci-images/minimal/mingw:jammy script: - bash ./tools/ci/cross-win64.sh qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab/000077500000000000000000000000001522610125300224325ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab/ubuntu-image/000077500000000000000000000000001522610125300250345ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab/ubuntu-image/Dockerfile.jammy000066400000000000000000000014231522610125300301420ustar00rootroot00000000000000FROM ubuntu:jammy ENV DEBIAN_FRONTEND=noninteractive RUN apt update ; \ apt install --yes cmake libblas-dev libblas64-dev liblapack-dev liblapack64-dev libopenblas-dev git;\ apt install --yes build-essential;\ apt install --yes gfortran ninja-build debhelper lcov RUN apt install --yes gcovr wget pkg-config RUN cd /tmp && \ wget -q https://github.com/fortran-lang/fpm/archive/refs/tags/v0.13.0.tar.gz && \ wget -q https://github.com/fortran-lang/fpm/releases/download/v0.13.0/fpm-0.13.0.F90 && \ tar xf v0.13.0.tar.gz && \ mkdir -p build/bootstrap && \ gfortran -J build/bootstrap -o build/bootstrap/fpm fpm-0.13.0.F90 && \ cd fpm-0.13.0 && \ ../build/bootstrap/fpm install --profile release --prefix /usr/local/ && \ cd / && rm -rf /tmp/* qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab/ubuntu-image/Dockerfile.latest000066400000000000000000000014431522610125300303230ustar00rootroot00000000000000FROM ubuntu:resolute ENV DEBIAN_FRONTEND noninteractive RUN apt update ; \ apt install --yes cmake libblas-dev libblas64-dev liblapack-dev liblapack64-dev libopenblas-dev git;\ apt install --yes build-essential;\ apt install --yes gfortran clang flang ninja-build debhelper lcov RUN apt install --yes gcovr wget pkg-config RUN cd /tmp && \ wget -q https://github.com/fortran-lang/fpm/archive/refs/tags/v0.13.0.tar.gz && \ wget -q https://github.com/fortran-lang/fpm/releases/download/v0.13.0/fpm-0.13.0.F90 && \ tar xf v0.13.0.tar.gz && \ mkdir -p build/bootstrap && \ gfortran -J build/bootstrap -o build/bootstrap/fpm fpm-0.13.0.F90 && \ cd fpm-0.13.0 && \ ../build/bootstrap/fpm install --profile release --prefix /usr/local/ && \ cd / && rm -rf /tmp/* qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab/ubuntu-image/Dockerfile.noble000066400000000000000000000014401522610125300301230ustar00rootroot00000000000000FROM ubuntu:noble ENV DEBIAN_FRONTEND noninteractive RUN apt update ; \ apt install --yes cmake libblas-dev libblas64-dev liblapack-dev liblapack64-dev libopenblas-dev git;\ apt install --yes build-essential;\ apt install --yes gfortran clang flang ninja-build debhelper lcov RUN apt install --yes gcovr wget pkg-config RUN cd /tmp && \ wget -q https://github.com/fortran-lang/fpm/archive/refs/tags/v0.13.0.tar.gz && \ wget -q https://github.com/fortran-lang/fpm/releases/download/v0.13.0/fpm-0.13.0.F90 && \ tar xf v0.13.0.tar.gz && \ mkdir -p build/bootstrap && \ gfortran -J build/bootstrap -o build/bootstrap/fpm fpm-0.13.0.F90 && \ cd fpm-0.13.0 && \ ../build/bootstrap/fpm install --profile release --prefix /usr/local/ && \ cd / && rm -rf /tmp/* qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/.gitlab/ubuntu-image/Dockerfile.resolute000066400000000000000000000014441522610125300306720ustar00rootroot00000000000000FROM ubuntu:resolute ENV DEBIAN_FRONTEND noninteractive RUN apt update ; \ apt install --yes cmake libblas-dev libblas64-dev liblapack-dev liblapack64-dev libopenblas-dev git;\ apt install --yes build-essential;\ apt install --yes gfortran clang flang ninja-build debhelper lcov RUN apt install --yes gcovr wget pkg-config RUN cd /tmp && \ wget -q https://github.com/fortran-lang/fpm/archive/refs/tags/v0.13.0.tar.gz && \ wget -q https://github.com/fortran-lang/fpm/releases/download/v0.13.0/fpm-0.13.0.F90 && \ tar xf v0.13.0.tar.gz && \ mkdir -p build/bootstrap && \ gfortran -J build/bootstrap -o build/bootstrap/fpm fpm-0.13.0.F90 && \ cd fpm-0.13.0 && \ ../build/bootstrap/fpm install --profile release --prefix /usr/local/ && \ cd / && rm -rf /tmp/* qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/CHANGELOG.md000066400000000000000000000064571522610125300227370ustar00rootroot00000000000000# Changelog ## Version 1.2.0 (2026-07-16) * Require at least CMake 3.18 * Documentation rewrite. Now, we use proper doxygen. * Convert to free form Fortran * Add code coverage builds * Add fortran module `qrupdate` * Make zdotc, zdotu, cdotc, and cdotu compatibel with different ABI's * add tests for parameter validation * add tests for (s|c|d|z)gqvec * Adjusted tolerance in tests, fix GH #4 ## Old Changelog ``` 2022-02-04 Martin Koehler * Fix Tests on CYGWIN (GH #2) * Enable MingW cross compiling 2022-02-04 Martin Koehler * Fix Tests on CYGWIN (GH #2) * Enable MingW cross compiling 2020-12-10 Martin Koehler * Fix failed tchinc test on aarch64 2020-05-11 Martin Koehler , Christian Himpe * Switch fron custom makefile to CMAKE * Fix warnings in the source and the tests * Support for IBM XLF compiler and IBM ESSL as BLAS and LAPACK. * drop support for F77 compilers * Update documentation 2012-02-06 Jaroslav Hajek * src/sqrder.f, src/dqrder.f, src/cqrder.f, src/zqrder.f: Fix fast return conditions for out-of-bounds row. 2010-02-11 Jaroslav Hajek * test/utils.f: Test CHERK and ZHERK results for validity. Warn about possibly buggy BLAS routines. * test/report_results: Dump out the warnings at the end. 2010-02-11 Jaroslav Hajek * test/utils.f: Correct invalid calls to xLANGE. Make dummy workspace decls consistent. 2010-02-11 Jaroslav Hajek * test/Makefile: Ensure the test output file is created to prevent errors from report_results. 2010-01-19 Fabian Groffen * Makeconf: Define DESTDIR. * src/Makefile: Prefix DESTDIR to install targets, to comply with GNU Makefile standard. 2010-01-19 Fabian Groffen * src/Makefile: Define SOEXT and set it correctly for Darwin. Use it in build and install rules. 2010-01-11 Jaroslav Hajek * Makeconf: Mark version 1.1. * README: Document LU updating routines. 2009-10-08 Jaroslav Hajek * src/slup1up.f: New source. * src/dlup1up.f: New source. * src/clup1up.f: New source. * src/zlup1up.f: New source. * src/Makefile: Include them. * src/slu1up.f: Mention algorithm source. * src/dlu1up.f: Ditto. * src/clu1up.f: Ditto. * src/zlu1up.f: Ditto. * src/EXPORTS: Update. * test/utils.f (P2IPIV, SLUPGEN, DLUPGEN, CLUPGEN, ZLUPGEN, SLUPCHK, DLUPCHK, CLUPCHK, ZLUPCHK): New subroutines. * test/tlup1up.f: New source. * test/Makefile: Include it. 2009-10-05 Jaroslav Hajek * src/slu1up.f: New source. * src/dlu1up.f: New source. * src/clu1up.f: New source. * src/zlu1up.f: New source. * src/Makefile: Include them in build. * test/utils.f (SLUGEN, DLUGEN, CLUGEN, ZLUGEN, SLUCHK, DLUCHK, CLUCHK, ZLUCHK): New subroutines. * test/tlu1up.f: New source. * test/Makefile: Include it. 2009-02-06 Jordi Gutiérrez Hermoso * Makeconf: Set default PREFIX. * Makefile: Add install targets. * src/Makefile: Likewise. 2009-02-04 Jaroslav Hajek * ChangeLog: Create. * src/Makefile: Specify BLAS and LAPACK when creating dynamic library. ``` qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/CMakeLists.txt000066400000000000000000000110301522610125300236450ustar00rootroot00000000000000CMAKE_MINIMUM_REQUIRED(VERSION 3.18.0) CMAKE_POLICY(SET CMP0048 NEW) PROJECT(qrupdate-ng VERSION 1.2.0 LANGUAGES Fortran) ENABLE_TESTING() # Options OPTION(BUILD_SHARED_LIBS "Build shared libraries" ON) OPTION(BUILD_STATIC_LIBS "Build static libraries" ON) OPTION(DEBUG "Enable Debug Symbol generation" OFF) if (NOT ( BUILD_SHARED_LIBS OR BUILD_STATIC_LIBS ) ) MESSAGE(FATAL_ERROR "Either BUILD_SHARED_LIBS or BUILD_STATIC_LIBS must be set to ON.") endif() # SET(CMAKE_POSITION_INDEPENDENT_CODE TRUE) IF ( DEBUG STREQUAL ON ) SET (CMAKE_BUILD_TYPE "Debug") ADD_DEFINITIONS(-DDEBUG) ENDIF() IF(NOT CMAKE_BUILD_TYPE) SET (CMAKE_BUILD_TYPE "Release") ENDIF() # Output directories IF(CMAKE_CURRENT_SOURCE_DIR STREQUAL CMAKE_SOURCE_DIR) SET(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/lib) SET(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/lib) SET(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/bin) ENDIF() # Required to work with Intel MKL IF (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel" OR BLA_VENDOR MATCHES "Intel.*") ENABLE_LANGUAGE(C) ENDIF() # Add addtional CMAKE Paths. LIST(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/cmake") # enable code coverage find_package(codecov) SET(Fortran_MODULE_NAME qrupdate) INCLUDE(FortranCompilerSettings) INCLUDE(GNUInstallDirs) INCLUDE(FortranModuleDir) # IBM XLF Compilation IF( CMAKE_Fortran_COMPILER_ID STREQUAL "XL") SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qfixed -qnosave") ENDIF() # Find Doxygen find_package(Doxygen OPTIONAL_COMPONENTS dot) if (INTEGER8 STREQUAL ON) cmake_minimum_required(VERSION 3.22) SET(BLA_SIZEOF_INTEGER 8) endif() FIND_PACKAGE(BLAS REQUIRED) MESSAGE(STATUS "BLAS Vendor: ${BLA_VENDOR}") IF(NOT BLA_VENDOR STREQUAL "IBMESSL") FIND_PACKAGE(LAPACK REQUIRED) ELSE() SET(LAPACK_MISSING_TARGET_NAME lapack_missing) INCLUDE(${CMAKE_SOURCE_DIR}/lapack-missing/LapackMissing.cmake) SET(LAPACK_FOUND TRUE) SET(LAPACK_LIBRARIES ${BLAS_LIBRARIES}) ENDIF() ADD_SUBDIRECTORY(src) ADD_SUBDIRECTORY(test) # Add documentation target if(DOXYGEN_FOUND) # Configure Doxygen to extract all functions including undocumented ones # and to browse source files set(DOXYGEN_EXTRACT_ALL YES) set(DOXYGEN_EXTRACT_STATIC YES) set(DOXYGEN_SOURCE_BROWSER YES) set(DOXYGEN_GENERATE_TREEVIEW YES) # Optimize output for Fortran set(DOXYGEN_OPTIMIZE_OUTPUT_FOR_FORTRAN YES) set(DOXYGEN_OUTPUT_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/doc") # Set input directories and files set(DOXYGEN_INPUT_DIR ${CMAKE_CURRENT_SOURCE_DIR}/README.md ${CMAKE_CURRENT_SOURCE_DIR}/INSTALL.md ${CMAKE_CURRENT_SOURCE_DIR}/CHANGELOG.md ${CMAKE_CURRENT_SOURCE_DIR}/src/categories.doxy ${CMAKE_CURRENT_SOURCE_DIR}/LICENSE ${CMAKE_CURRENT_SOURCE_DIR}/src) set(DOXYGEN_USE_MDFILE_AS_MAINPAGE ${CMAKE_CURRENT_SOURCE_DIR}/README.md) set(DOXYGEN_MARKDOWN_SUPPORT YES) set(DOXYGEN_EXCLUDE_PATTERNS "*/build*/*") # Configure Doxygen doxygen_add_docs(doc ${DOXYGEN_INPUT_DIR} ALL COMMENT "Generate documentation" ) install(DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/doc/html/ TYPE DOC) endif() INCLUDE(CMakePackageConfigHelpers) WRITE_BASIC_PACKAGE_VERSION_FILE( qrupdateConfigVersion.cmake VERSION ${PROJECT_VERSION} COMPATIBILITY AnyNewerVersion ) INSTALL(EXPORT qrupdatetargets FILE qrupdateTargets.cmake NAMESPACE qrupdate:: DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/qrupdate ) CONFIGURE_FILE(qrupdate-config.cmake.in qrupdate-config.cmake @ONLY) INSTALL(FILES "${CMAKE_CURRENT_BINARY_DIR}/qrupdate-config.cmake" "${CMAKE_CURRENT_BINARY_DIR}/qrupdateConfigVersion.cmake" DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/qrupdate ) CONFIGURE_FILE(qrupdate.pc.in qrupdate.pc @ONLY) INSTALL(FILES "${CMAKE_CURRENT_BINARY_DIR}/qrupdate.pc" DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig") MESSAGE(STATUS "------------ Build Information --------------") MESSAGE(STATUS "CMAKE_Fortran_FLAGS: ${CMAKE_Fortran_FLAGS}") MESSAGE(STATUS "CMAKE_Fortran_FLAGS_DEBUG: ${CMAKE_Fortran_FLAGS_DEBUG}") MESSAGE(STATUS "CMAKE_Fortran_FLAGS_RELEASE: ${CMAKE_Fortran_FLAGS_RELEASE}") MESSAGE(STATUS "BLAS Libraries: ${BLAS_LIBRARIES}") MESSAGE(STATUS "LAPACK Libraries: ${LAPACK_LIBRARIES}") MESSAGE(STATUS "Build Type: ${CMAKE_BUILD_TYPE}") MESSAGE(STATUS "Debug: ${DEBUG}") MESSAGE(STATUS "Shared Libs: ${BUILD_SHARED_LIBS}") MESSAGE(STATUS "---------------------------------------------") coverage_evaluate() qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/CODE000066400000000000000000000012051522610125300215450ustar00rootroot00000000000000# code.ini name: qrupdate-ng shortname: qrupdate-ng version: 1.2.0 release-date: 2026-07-16 id: https://github.com/mpimd-csc/qrupdate-ng id-type: url author: Martin Koehler, Christian Himpe orcid: 0000-0003-2338-9904, 0000-0003-2194-6754 topic: Science, Mathematics, Numerical Linear Algebra type: Library license: GPL-3.0-or-later license-type: open-source repository: github.com/mpimd-csc/qrupdate-ng repository-type: git language: FORTRAN dependencies: BLAS, LAPACK systems: Linux, Windows website: https://github.com/mpimd-csc/qrupdate-ng keywords: QR Decomposition, Cholesky Decomposition, LU Decomposition, Matrix Decomposition, QR Update qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/INSTALL.md000066400000000000000000000134541522610125300225510ustar00rootroot00000000000000Installation Notes ================== The library is written in Fortran. It is Fortran-90/95-compliant. Fortran 77 compilers are no longer supported. This includes the f2c translator as well. ## Requirements The library requires a Fortran 90/95 compiler, BLAS, and LAPACK. The following compilers and BLAS/LAPACK implementations are tested under Linux. Other operating systems, which are supported by CMAKE, should work as well. **Required CMake Version:** 3.18 Tested Fortran compilers: * GNU gfortran >= 9.3 * Intel ifort >= 18.0.1 * Intel oneAPI ifx >= 2024 The AMD AOCC 5.x compiler compiles the code, but the generated code may contain invalid memory accesses. Please check carefully if the required routines work correctly in your application. Tested BLAS/LAPACK implementations: * Reference BLAS/LAPACK, http://www.netlib.org/lapack * OpenBLAS, https://www.openblas.net * FlexiBLAS, https://www.mpi-magdeburg.mpg.de/projects/ flexiblas * Intel MKL, https://software.intel.com/en-us/mkl * IBM ESSL (Missing LAPACK routines are automatically added.), https://www.ibm.com/support/knowledgecenter/en/SSFHY8 ## Configuration and Installation CMAKE is used to configure the source code. Out-of-source builds are prefered. The default installation of qrupdate-ng is done by mkdir -p build && cd build cmake ../ -DCMAKE_INSTALL_PREFIX=/your/installation/path/ make make install The installation can adjusted with the help of the CMAKE options. Beside the standard options of CMAKE, the following ones are supported: | **Option** | **Description** | |--------------------------------|---------------------------------------------| | `-DDEBUG=OFF/ON` | Enable the debug build. | | `-DHOSTOPT=OFF/ON` | Enable host specific compiler flags. | | `-DENABLE_COVERAGE=OFF/ON` | Enable code coverage. | | `-DFORTRAN_BOUND_CHECK=OFF/ON` | Enable the runtime bound checker. | | `-DFORTRAN_SANITIZE=OFF/ON` | Enable the runtime sanitizer. | | `-DBUILD_SHARED_LIBS=ON/OFF` | Enable building of shared libraries. | | `-DBUILD_STATIC_LIBS=ON/OFF` | Enable building of static libraries. | The `FORTRAN_BOUND_CHECK` option is only supported for gfortran and ifort compilers. The `FORTRAN_SANITIZE` option can only be used with the gfortran compiler. If the host optimizations are enabled, the build might not be portable to other computers. The qrupdate-ng code includes a testsuite which can be executed by `make test`. ## ILP64 Binaries If you need qrupdate-ng with 64 bit integers, i.e. the ILP64 integer model, you can add ``` -DINTEGER8=ON ``` to the cmake command line. Since this enables the `-fdefault-integer-8` flag (in case of the GNU compilers), this leads to warning during the compilation, since these types of flags are not compatible with the `iso_fortran_env` module. In future versions of qrupdate, the ILP64 build with be refactored to be portable and compatible with the `iso_fortran_env` module. **Attention**: Enabling the ILP64 build requires at least CMake 3.22 ### Selecting individual BLAS and LAPACK libraries By default CMAKE uses the first BLAS and LAPACK library it finds on the system. If a special selection is required, one can either specifiy the `BLA_VENDOR` vendor option of CMAKE's `FindBLAS.cmake` module or specify the BLAS and LAPACK libraries completly on ones own. Possible values for the `BLA_VENDOR` options can be found in the help of the `FindBLAS.cmake` module and can be obtained by `cmake --help-module FindBLAS`. A custom BLAS and LAPACK library can be specified by setting the `BLAS_LIBRRARIES` and `LAPACK_LIBRARIES` variables. The variable contain a semicolon separated list of libraries that are required to provide the BLAS and LAPACK functionality. If a libraries contains both, BLAS and LAPACK, it needs to be set in both variables. An example to use a self-compiled reference BLAS and LAPACK could yield the following CMAKE call: cmake ../ -DBLAS_LIBRARIES=/home/user/software/libblas.a \ -DLAPACK_LIBRARIES=/home/user/software/liblapack.a ## Cross Compiling for Windows The build system supports cross compiling from Unix-like operating systems to Windows. Therefore, MingW64 (https://www.mingw-w64.org/) and Wine (https://www.winehq.org/) need to be present on the system. In case of Ubuntu 20.04 the following packages are required: * `mingw-w64`, `mingw-w64-i686-dev` , `mingw-w64-x86-64-dev` * `gfortran-mingw-w64-i686`, `gfortran-mingw-w64-x86-64` * `wine32`, `wine64` * `wget` Furthermore, BLAS and LAPACK are required in the MingW installation. If this is not the case, the reference BLAS and LAPACK library can be installed via ```shell bash ./tools/install-lapack-mingw-i686.sh ``` for the Windows 32-bit environment, and using ```shelll bash ./tools/install-lapack-mingw-x86_64.sh ``` for the Windows 64-bit environment. The Windows 32-bit library can then be compiled using ```shell cmake -S . -B build.win32 \ -DCMAKE_TOOLCHAIN_FILE=$(pwd)/cmake/mingw-w32-i686.cmake \ -DBUILD_SHARED_LIBS=ON \ -DCMAKE_INSTALL_PREFIX=$(pwd)/install-win32 make -C build.win32 all (cd build.win32; ctest -V ) make -C build.win32 install ``` In case of the 64-bit Windows library, the build process looks like ```shell cmake -S . -B build.win64 \ -DCMAKE_TOOLCHAIN_FILE=$(pwd)/cmake/mingw-w64-x86_64.cmake \ -DBUILD_SHARED_LIBS=ON \ -DCMAKE_INSTALL_PREFIX=$(pwd)/install-win32 make -C build.win64 all (cd build.win64; ctest -V ) make -C build.win64 install ``` ## Documentation The library uses Doxygen for documenting the source code. If Doxygen is installed in the system, cmake will detect it. After configuring the documentation can bei built using ```shell make doc ``` and gets available in `doc/html`. qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/LICENSE000066400000000000000000001045131522610125300221230ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/README.md000066400000000000000000000100411522610125300223650ustar00rootroot00000000000000qrupdate-ng =========== A Library for Fast Updating of QR, Cholesky, and LU Decompositions Version: 1.2.0 (2026-07-16) * Authors: M. Koehler (0000-0003-2338-9904), C. Himpe (0000-0003-2194-6754) * Original Author: Jaroslav Hajek (VZLU Prague) ## Supported Matrix Decompositions The library supports the follwoing matrix decompositions ### QR Decomposition See [QR Decompositions](\ref qrdecomp) for details. This following operations are supported: * QR rank-1 update (`qr1up`) Updates the QR factorization after an additive rank-1 update to the original matrix. Works for full and economized factorization. * QR column insert (`qrinc`) Updates the QR factorization after an inserting a column to the original matrix. Works for full and economized factorization. * QR column delete (`qrdec`) Updates the QR factorization after an deleting a column from the original matrix. Works for full and economized factorization. * QR column shift (`qrshc`) Updates the QR factorization after a circular shift of columns in the original matrix. Works for full and economized factorization. * QR row insert (`qrinr`) Updates the QR factorization after an inserting a row to the original matrix. Works for full factorization only. * QR row delete (`qrder`) Updates the QR factorization after an deleting a row from the original matrix. Works for full factorization only. ### Cholesky Decomposition See [Cholesky Decompositions](\ref choldecomp) for details. This following operations are supported: * Cholesky rank-1 update (`ch1up`) Updates the Cholesky factorization after positive rank-1 update. * Cholesky rank-1 downdate (`ch1dn`) Updates the Cholesky factorization after positive rank-1 downdate. * Cholesky symmetric insert (`chinx`) Updates the Cholesky factorization after a symmetric column/row insertion. * Cholesky symmetric insert (`chdex`) Updates the Cholesky factorization after a symmetric column/row deletion. * Cholesky symmetric shift (`chshx`) Updates the Cholesky factorization after a symmetric column/row left/right circular shift. ### LU Decomposition See [LU Decompositions](\ref ludecomp) for details. This following operations are supported: * LU rank-1 update (`lu1up`) Updates the LU factorization after a rank-1 update. No pivoting available. Faster than `lup1up`, but less stable. * LU pivoted rank-1 update (`lup1up`) Updates a row-pivoted LUP factorization after a rank-1 update. Also updates the row permutation matrix. Slower than `lu1up`, but more stable. ## Installation See the [INSTALL](INSTALL.md) file for installation details. Consult individual routines for documentation. ### Fortran Package Manager If you are using the Fortran Package Manager [FPM](https://fpm.fortran-lang.org/) you can add `qrupdate-ng` as dependency by including the following in your `fpm.toml`: ```toml [dependencies] qrupdate-ng = { git = "https://github.com/mpimd-csc/qrupdate-ng.git", branch = "main" } ``` ### CMake's FetchContent `qrupdate-ng` can be used with CMake's [FetchContent](https://cmake.org/cmake/help/latest/module/FetchContent.html) mechanism. Therefore just include ```cmake FetchContent_Declare( qrupdate GIT_REPOSITORY https://github.com/mpimd-csc/qrupdate-ng.git GIT_TAG master # Or the tag of the desired version ) FetchContent_MakeAvailable(qrupdate) ``` and link your targets agains `qrupdate::qrupdate`. ### CPM Support [CPM](https://github.com/cpm-cmake/cpm.cmake) is a package manager on top of CMake's FetchContent mechnism. It simiplies the usage of `FetchContent`. Just include `CPM` and add `qrupdate-ng` using ```cmake CPMAddPackage("gh:mpimd-csc/qrupdate-ng#master") ``` and link your targets agains `qrupdate::qrupdate`. ## Based on qrupdate-ng is a modernized and maintained fork of: [qrupdate](https://sourceforge.net/p/qrupdate) (Version 1.1.2) For a list of original authors see [CHANGELOG](CHANGELOG.md) file. ## License License: GPL-3.0-or-later (opensource.org/licenses/GPL-3.0) See `LICENSE` for details. qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/TODO000066400000000000000000000002061522610125300216000ustar00rootroot00000000000000# TODO * Fix Code smells * Profile and improve performance? * Add minimal "getting started" examples? * 64-Bit integer support * ... qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/000077500000000000000000000000001522610125300221725ustar00rootroot00000000000000CheckFortranCompilerFlag_meta.cmake000066400000000000000000000002211522610125300307540ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmakeIF(${CMAKE_VERSION} VERSION_LESS "3.0.0") INCLUDE(CheckFortranCompilerFlag_old) ELSE() INCLUDE(CheckFortranCompilerFlag) ENDIF() qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/CheckFortranCompilerFlag_old.cmake000066400000000000000000000045041522610125300306730ustar00rootroot00000000000000# Distributed under the OSI-approved BSD 3-Clause License. See accompanying # file Copyright.txt or https://cmake.org/licensing for details. #.rst: # CheckFortranCompilerFlag # ------------------------ # # Check whether the Fortran compiler supports a given flag. # # CHECK_Fortran_COMPILER_FLAG( ) # # :: # # - the compiler flag # - variable to store the result # Will be created as an internal cache variable. # # This internally calls the check_fortran_source_compiles macro and # sets CMAKE_REQUIRED_DEFINITIONS to . See help for # CheckFortranSourceCompiles for a listing of variables that can # otherwise modify the build. The result only tells that the compiler # does not give an error message when it encounters the flag. If the # flag has any effect or even a specific one is beyond the scope of # this module. # # -------------------------------------------------------- # THIS IS A REPLACEMENT IF THE CMAKE VERSION IS TOO OLD # WE USE THIS MODULE. # -------------------------------------------------------- INCLUDE(CheckFortranSourceCompiles_old) INCLUDE(CMakeCheckCompilerFlagCommonPatterns_old) MACRO(CHECK_Fortran_COMPILER_FLAG _FLAG _RESULT) SET(SAFE_CMAKE_REQUIRED_DEFINITIONS "${CMAKE_REQUIRED_DEFINITIONS}") SET(CMAKE_REQUIRED_DEFINITIONS "${_FLAG}") # Normalize locale during test compilation. SET(_CheckFortranCompilerFlag_LOCALE_VARS LC_ALL LC_MESSAGES LANG) FOREACH(v ${_CheckFortranCompilerFlag_LOCALE_VARS}) SET(_CheckFortranCompilerFlag_SAVED_${v} "$ENV{${v}}") SET(ENV{${v}} C) ENDFOREACH() CHECK_COMPILER_FLAG_COMMON_PATTERNS(_CheckFortranCompilerFlag_COMMON_PATTERNS) CHECK_FORTRAN_SOURCE_COMPILES(" program test\n stop\n end program" ${_RESULT} # Some compilers do not fail with a bad flag FAIL_REGEX "command line option .* is valid for .* but not for Fortran" # GNU ${_CheckFortranCompilerFlag_COMMON_PATTERNS} ) FOREACH(v ${_CheckFortranCompilerFlag_LOCALE_VARS}) SET(ENV{${v}} ${_CheckFortranCompilerFlag_SAVED_${v}}) UNSET(_CheckFortranCompilerFlag_SAVED_${v}) ENDFOREACH() UNSET(_CheckFortranCompilerFlag_LOCALE_VARS) UNSET(_CheckFortranCompilerFlag_COMMON_PATTERNS) SET(CMAKE_REQUIRED_DEFINITIONS "${SAFE_CMAKE_REQUIRED_DEFINITIONS}") ENDMACRO() CheckFortranSourceCompiles_meta.cmake000066400000000000000000000002151522610125300313470ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmakeIF(${CMAKE_VERSION} VERSION_LESS "3.0.0") INCLUDE(CheckFortranSourceCompiles_old) ELSE() INCLUDE(CheckFortranSourceCompiles) ENDIF() CheckFortranSourceCompiles_old.cmake000066400000000000000000000103711522610125300312030ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake# Distributed under the OSI-approved BSD 3-Clause License. See accompanying # file Copyright.txt or https://cmake.org/licensing for details. #.rst: # CheckFortranSourceCompiles # -------------------------- # # Check if given Fortran source compiles and links into an executable:: # # CHECK_Fortran_SOURCE_COMPILES( [FAIL_REGEX ] # [SRC_EXT ]) # # The arguments are: # # ```` # Source code to try to compile. It must define a PROGRAM entry point. # ```` # Variable to store whether the source code compiled. # Will be created as an internal cache variable. # ``FAIL_REGEX `` # Fail if test output matches this regex. # ``SRC_EXT `` # Use source extension ``.`` instead of the default ``.F``. # # The following variables may be set before calling this macro to modify # the way the check is run:: # # CMAKE_REQUIRED_FLAGS = string of compile command line flags # CMAKE_REQUIRED_DEFINITIONS = list of macros to define (-DFOO=bar) # CMAKE_REQUIRED_INCLUDES = list of include directories # CMAKE_REQUIRED_LIBRARIES = list of libraries to link # CMAKE_REQUIRED_QUIET = execute quietly without messages # # # -------------------------------------------------------- # THIS IS A REPLACEMENT IF THE CMAKE VERSION IS TOO OLD # WE USE THIS MODULE. # -------------------------------------------------------- MACRO(CHECK_Fortran_SOURCE_COMPILES SOURCE VAR) IF(NOT DEFINED "${VAR}") SET(_FAIL_REGEX) SET(_SRC_EXT) SET(_key) FOREACH(arg ${ARGN}) IF("${arg}" MATCHES "^(FAIL_REGEX|SRC_EXT)$") SET(_key "${arg}") ELSEIF(_key) LIST(APPEND _${_key} "${arg}") ELSE() MESSAGE(FATAL_ERROR "Unknown argument:\n ${arg}\n") ENDIF() ENDFOREACH() IF(NOT _SRC_EXT) SET(_SRC_EXT F) ENDIF() SET(MACRO_CHECK_FUNCTION_DEFINITIONS "-D${VAR} ${CMAKE_REQUIRED_FLAGS}") IF(CMAKE_REQUIRED_LIBRARIES) SET(CHECK_Fortran_SOURCE_COMPILES_ADD_LIBRARIES LINK_LIBRARIES ${CMAKE_REQUIRED_LIBRARIES}) ELSE() SET(CHECK_Fortran_SOURCE_COMPILES_ADD_LIBRARIES) ENDIF() IF(CMAKE_REQUIRED_INCLUDES) SET(CHECK_Fortran_SOURCE_COMPILES_ADD_INCLUDES "-DINCLUDE_DIRECTORIES:STRING=${CMAKE_REQUIRED_INCLUDES}") ELSE() SET(CHECK_Fortran_SOURCE_COMPILES_ADD_INCLUDES) ENDIF() FILE(WRITE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/src.${_SRC_EXT}" "${SOURCE}\n") IF(NOT CMAKE_REQUIRED_QUIET) MESSAGE(STATUS "Performing Test ${VAR}") ENDIF() TRY_COMPILE(${VAR} ${CMAKE_BINARY_DIR} ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/src.${_SRC_EXT} COMPILE_DEFINITIONS ${CMAKE_REQUIRED_DEFINITIONS} ${CHECK_Fortran_SOURCE_COMPILES_ADD_LIBRARIES} CMAKE_FLAGS -DCOMPILE_DEFINITIONS:STRING=${MACRO_CHECK_FUNCTION_DEFINITIONS} "${CHECK_Fortran_SOURCE_COMPILES_ADD_INCLUDES}" OUTPUT_VARIABLE OUTPUT) FOREACH(_regex ${_FAIL_REGEX}) IF("${OUTPUT}" MATCHES "${_regex}") SET(${VAR} 0) ENDIF() ENDFOREACH() IF(${VAR}) SET(${VAR} 1 CACHE INTERNAL "Test ${VAR}") IF(NOT CMAKE_REQUIRED_QUIET) MESSAGE(STATUS "Performing Test ${VAR} - Success") ENDIF() FILE(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log "Performing Fortran SOURCE FILE Test ${VAR} succeeded with the following output:\n" "${OUTPUT}\n" "Source file was:\n${SOURCE}\n") ELSE() IF(NOT CMAKE_REQUIRED_QUIET) MESSAGE(STATUS "Performing Test ${VAR} - Failed") ENDIF() SET(${VAR} "" CACHE INTERNAL "Test ${VAR}") FILE(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log "Performing Fortran SOURCE FILE Test ${VAR} failed with the following output:\n" "${OUTPUT}\n" "Source file was:\n${SOURCE}\n") ENDIF() ENDIF() ENDMACRO() qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/FindGcov.cmake000066400000000000000000000123651522610125300247020ustar00rootroot00000000000000# This file is part of CMake-codecov. # # SPDX-FileCopyrightText: RWTH Aachen University, Federal Republic of Germany # SPDX-FileContributor: Alexander Haase, alexander.haase@rwth-aachen.de # # SPDX-License-Identifier: BSD-3-Clause # include required Modules include(FindPackageHandleStandardArgs) # Search for gcov binary. set(CMAKE_REQUIRED_QUIET_SAVE ${CMAKE_REQUIRED_QUIET}) set(CMAKE_REQUIRED_QUIET ${codecov_FIND_QUIETLY}) get_property(ENABLED_LANGUAGES GLOBAL PROPERTY ENABLED_LANGUAGES) foreach (LANG ${ENABLED_LANGUAGES}) # Gcov evaluation is dependent on the used compiler. Check gcov support for # each compiler that is used. If gcov binary was already found for this # compiler, do not try to find it again. if (NOT GCOV_${CMAKE_${LANG}_COMPILER_ID}_BIN) get_filename_component(COMPILER_PATH "${CMAKE_${LANG}_COMPILER}" PATH) if ("${CMAKE_${LANG}_COMPILER_ID}" STREQUAL "GNU") # Some distributions like OSX (homebrew) ship gcov with the compiler # version appended as gcov-x. To find this binary we'll build the # suggested binary name with the compiler version. string(REGEX MATCH "^[0-9]+" GCC_VERSION "${CMAKE_${LANG}_COMPILER_VERSION}") find_program(GCOV_BIN NAMES gcov-${GCC_VERSION} gcov HINTS ${COMPILER_PATH}) elseif ("${CMAKE_${LANG}_COMPILER_ID}" MATCHES "^(Apple)?Clang$") # Some distributions like Debian ship llvm-cov with the compiler # version appended as llvm-cov-x.y or just llvm-cov-x. To find this binary we'll build # the suggested binary name with the compiler version. string(REGEX MATCH "^[0-9]+\.[0-9]+" LLVM_FULL_VERSION "${CMAKE_${LANG}_COMPILER_VERSION}") string(REGEX MATCH "^[0-9]+" LLVM_MAJOR_VERSION "${CMAKE_${LANG}_COMPILER_VERSION}") # llvm-cov prior version 3.5 seems to be not working with coverage # evaluation tools, but these versions are compatible with the gcc # gcov tool. if(LLVM_FULL_VERSION VERSION_GREATER 3.4) find_program(LLVM_COV_BIN NAMES "llvm-cov-${LLVM_FULL_VERSION}" "llvm-cov-${LLVM_MAJOR_VERSION}" "llvm-cov" HINTS ${COMPILER_PATH}) mark_as_advanced(LLVM_COV_BIN) if (LLVM_COV_BIN) find_program(LLVM_COV_WRAPPER "llvm-cov-wrapper" PATHS ${CMAKE_MODULE_PATH}) if (LLVM_COV_WRAPPER) set(GCOV_BIN "${LLVM_COV_WRAPPER}" CACHE FILEPATH "") # set additional parameters set(GCOV_${CMAKE_${LANG}_COMPILER_ID}_ENV "LLVM_COV_BIN=${LLVM_COV_BIN}" CACHE STRING "Environment variables for llvm-cov-wrapper.") mark_as_advanced(GCOV_${CMAKE_${LANG}_COMPILER_ID}_ENV) endif () endif () endif () if (NOT GCOV_BIN) # Fall back to gcov binary if llvm-cov was not found or is # incompatible. This is the default on OSX, but may crash on # recent Linux versions. find_program(GCOV_BIN gcov HINTS ${COMPILER_PATH}) endif () endif () if (GCOV_BIN) set(GCOV_${CMAKE_${LANG}_COMPILER_ID}_BIN "${GCOV_BIN}" CACHE STRING "${LANG} gcov binary.") if (NOT CMAKE_REQUIRED_QUIET) message("-- Found gcov evaluation for " "${CMAKE_${LANG}_COMPILER_ID}: ${GCOV_BIN}") endif() unset(GCOV_BIN CACHE) endif () endif () endforeach () # Add a new global target for all gcov targets. This target could be used to # generate the gcov files for the whole project instead of calling -gcov # for each target. if (NOT TARGET gcov) add_custom_target(gcov) endif (NOT TARGET gcov) # This function will add gcov evaluation for target . Only sources of # this target will be evaluated and no dependencies will be added. It will call # Gcov on any source file of once and store the gcov file in the same # directory. function (add_gcov_target TNAME) get_target_property(TBIN_DIR ${TNAME} BINARY_DIR) set(TDIR ${TBIN_DIR}/CMakeFiles/${TNAME}.dir) # We don't have to check, if the target has support for coverage, thus this # will be checked by add_coverage_target in Findcoverage.cmake. Instead we # have to determine which gcov binary to use. get_target_property(TSOURCES ${TNAME} SOURCES) set(SOURCES "") set(TCOMPILER "") foreach (FILE ${TSOURCES}) codecov_path_of_source(${FILE} FILE) if (NOT "${FILE}" STREQUAL "") codecov_lang_of_source(${FILE} LANG) if (NOT "${LANG}" STREQUAL "") list(APPEND SOURCES "${FILE}") set(TCOMPILER ${CMAKE_${LANG}_COMPILER_ID}) endif () endif () endforeach () # If no gcov binary was found, coverage data can't be evaluated. if (NOT GCOV_${TCOMPILER}_BIN) message(WARNING "No coverage evaluation binary found for ${TCOMPILER}.") return() endif () set(GCOV_BIN "${GCOV_${TCOMPILER}_BIN}") set(GCOV_ENV "${GCOV_${TCOMPILER}_ENV}") set(BUFFER "") set(NULL_DEVICE "/dev/null") if(WIN32) set(NULL_DEVICE "NUL") endif() foreach(FILE ${SOURCES}) get_filename_component(FILE_PATH "${TDIR}/${FILE}" PATH) # call gcov add_custom_command(OUTPUT ${TDIR}/${FILE}.gcov COMMAND ${GCOV_ENV} ${GCOV_BIN} -p ${TDIR}/${FILE}.gcno > ${NULL_DEVICE} DEPENDS ${TNAME} ${TDIR}/${FILE}.gcno WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} ) list(APPEND BUFFER ${TDIR}/${FILE}.gcov) endforeach() # add target for gcov evaluation of add_custom_target(${TNAME}-gcov DEPENDS ${BUFFER}) # add evaluation target to the global gcov target. add_dependencies(gcov ${TNAME}-gcov) endfunction (add_gcov_target) qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/FindLcov.cmake000066400000000000000000000314001522610125300246760ustar00rootroot00000000000000# This file is part of CMake-codecov. # # SPDX-FileCopyrightText: RWTH Aachen University, Federal Republic of Germany # SPDX-FileContributor: Alexander Haase, alexander.haase@rwth-aachen.de # # SPDX-License-Identifier: BSD-3-Clause # configuration set(LCOV_DATA_PATH "${CMAKE_BINARY_DIR}/lcov/data") set(LCOV_DATA_PATH_INIT "${LCOV_DATA_PATH}/init") set(LCOV_DATA_PATH_CAPTURE "${LCOV_DATA_PATH}/capture") set(LCOV_HTML_PATH "${CMAKE_BINARY_DIR}/lcov/html") set(GENINFO_EXTRA_FLAGS "" CACHE STRING "Additional flags to pass to geninfo.") string(REPLACE " " ";" GENINFO_EXTRA_FLAGS "${GENINFO_EXTRA_FLAGS}") set(LCOV_EXTRA_FLAGS "" CACHE STRING "Additional flags to pass to lcov.") string(REPLACE " " ";" LCOV_EXTRA_FLAGS "${LCOV_EXTRA_FLAGS}") # Search for Gcov which is used by Lcov. find_package(Gcov) # This function will add lcov evaluation for target . Only sources of # this target will be evaluated and no dependencies will be added. It will call # geninfo on any source file of once and store the info file in the same # directory. # # Note: This function is only a wrapper to define this function always, even if # coverage is not supported by the compiler or disabled. This function must # be defined here, because the module will be exited, if there is no coverage # support by the compiler or it is disabled by the user. function (add_lcov_target TNAME) if (LCOV_FOUND) # capture initial coverage data lcov_capture_initial_tgt(${TNAME}) # capture coverage data after execution lcov_capture_tgt(${TNAME}) endif () endfunction (add_lcov_target) # include required Modules include(FindPackageHandleStandardArgs) # Search for required lcov binaries. find_program(LCOV_BIN lcov) find_program(GENINFO_BIN geninfo) find_program(GENHTML_BIN genhtml) find_package_handle_standard_args(Lcov REQUIRED_VARS LCOV_BIN GENINFO_BIN GENHTML_BIN ) # enable genhtml C++ demangeling, if c++filt is found. set(GENHTML_CPPFILT_FLAG "") find_program(CPPFILT_BIN c++filt) if (NOT CPPFILT_BIN STREQUAL "") set(GENHTML_CPPFILT_FLAG "--demangle-cpp") endif (NOT CPPFILT_BIN STREQUAL "") # enable no-external flag for lcov, if available. if (GENINFO_BIN AND NOT DEFINED GENINFO_EXTERN_FLAG) set(FLAG "") execute_process(COMMAND ${GENINFO_BIN} --help OUTPUT_VARIABLE GENINFO_HELP) string(REGEX MATCH "external" GENINFO_RES "${GENINFO_HELP}") if (GENINFO_RES) set(FLAG "--no-external") endif () set(GENINFO_EXTERN_FLAG "${FLAG}" CACHE STRING "Geninfo flag to exclude system sources.") endif () # If Lcov was not found, exit module now. if (NOT LCOV_FOUND) return() endif (NOT LCOV_FOUND) # Create directories to be used. file(MAKE_DIRECTORY ${LCOV_DATA_PATH_INIT}) file(MAKE_DIRECTORY ${LCOV_DATA_PATH_CAPTURE}) set(LCOV_REMOVE_PATTERNS "") # This function will merge lcov files to a single target file. Additional lcov # flags may be set with setting LCOV_EXTRA_FLAGS before calling this function. function (lcov_merge_files OUTFILE ...) # Remove ${OUTFILE} from ${ARGV} and generate lcov parameters with files. list(REMOVE_AT ARGV 0) # Generate merged file. string(REPLACE "${CMAKE_BINARY_DIR}/" "" FILE_REL "${OUTFILE}") add_custom_command(OUTPUT "${OUTFILE}.raw" COMMAND cat ${ARGV} > ${OUTFILE}.raw DEPENDS ${ARGV} COMMENT "Generating ${FILE_REL}" ) add_custom_command(OUTPUT "${OUTFILE}" COMMAND ${LCOV_BIN} --quiet -a ${OUTFILE}.raw --output-file ${OUTFILE} --base-directory ${PROJECT_SOURCE_DIR} ${LCOV_EXTRA_FLAGS} COMMAND ${LCOV_BIN} --quiet -r ${OUTFILE} ${LCOV_REMOVE_PATTERNS} --output-file ${OUTFILE} ${LCOV_EXTRA_FLAGS} DEPENDS ${OUTFILE}.raw COMMENT "Post-processing ${FILE_REL}" ) endfunction () # Add a new global target to generate initial coverage reports for all targets. # This target will be used to generate the global initial info file, which is # used to gather even empty report data. if (NOT TARGET lcov-capture-init) add_custom_target(lcov-capture-init) set(LCOV_CAPTURE_INIT_FILES "" CACHE INTERNAL "") endif (NOT TARGET lcov-capture-init) # This function will add initial capture of coverage data for target , # which is needed to get also data for objects, which were not loaded at # execution time. It will call geninfo for every source file of once and # store the info file in the same directory. function (lcov_capture_initial_tgt TNAME) # We don't have to check, if the target has support for coverage, thus this # will be checked by add_coverage_target in Findcoverage.cmake. Instead we # have to determine which gcov binary to use. get_target_property(TSOURCES ${TNAME} SOURCES) set(SOURCES "") set(TCOMPILER "") foreach (FILE ${TSOURCES}) codecov_path_of_source(${FILE} FILE) if (NOT "${FILE}" STREQUAL "") codecov_lang_of_source(${FILE} LANG) if (NOT "${LANG}" STREQUAL "") list(APPEND SOURCES "${FILE}") set(TCOMPILER ${CMAKE_${LANG}_COMPILER_ID}) endif () endif () endforeach () # If no gcov binary was found, coverage data can't be evaluated. if (NOT GCOV_${TCOMPILER}_BIN) message(WARNING "No coverage evaluation binary found for ${TCOMPILER}.") return() endif () set(GCOV_BIN "${GCOV_${TCOMPILER}_BIN}") set(GCOV_ENV "${GCOV_${TCOMPILER}_ENV}") get_target_property(TBIN_DIR ${TNAME} BINARY_DIR) set(TDIR ${TBIN_DIR}/CMakeFiles/${TNAME}.dir) set(GENINFO_FILES "") foreach(FILE ${SOURCES}) # generate empty coverage files set(OUTFILE "${TDIR}/${FILE}.info.init") list(APPEND GENINFO_FILES ${OUTFILE}) add_custom_command(OUTPUT ${OUTFILE} COMMAND ${GCOV_ENV} ${GENINFO_BIN} --quiet --base-directory ${PROJECT_SOURCE_DIR} --initial --gcov-tool ${GCOV_BIN} --output-filename ${OUTFILE} ${GENINFO_EXTERN_FLAG} ${TDIR}/${FILE}.gcno ${GENINFO_EXTRA_FLAGS} DEPENDS ${TNAME} COMMENT "Capturing initial coverage data for ${FILE}" ) endforeach() # Concatenate all files generated by geninfo to a single file per target. set(OUTFILE "${LCOV_DATA_PATH_INIT}/${TNAME}.info") list(APPEND LCOV_EXTRA_FLAGS "--initial") lcov_merge_files("${OUTFILE}" ${GENINFO_FILES}) add_custom_target(${TNAME}-capture-init ALL DEPENDS ${OUTFILE}) # add geninfo file generation to global lcov-geninfo target add_dependencies(lcov-capture-init ${TNAME}-capture-init) set(LCOV_CAPTURE_INIT_FILES "${LCOV_CAPTURE_INIT_FILES}" "${OUTFILE}" CACHE INTERNAL "" ) endfunction (lcov_capture_initial_tgt) # This function will generate the global info file for all targets. It has to be # called after all other CMake functions in the root CMakeLists.txt file, to get # a full list of all targets that generate coverage data. function (lcov_capture_initial) # Skip this function (and do not create the following targets), if there are # no input files. if ("${LCOV_CAPTURE_INIT_FILES}" STREQUAL "") return() endif () # Add a new target to merge the files of all targets. set(OUTFILE "${LCOV_DATA_PATH_INIT}/all_targets.info") lcov_merge_files("${OUTFILE}" ${LCOV_CAPTURE_INIT_FILES}) add_custom_target(lcov-geninfo-init ALL DEPENDS ${OUTFILE} lcov-capture-init ) endfunction (lcov_capture_initial) # Add a new global target to generate coverage reports for all targets. This # target will be used to generate the global info file. if (NOT TARGET lcov-capture) add_custom_target(lcov-capture) set(LCOV_CAPTURE_FILES "" CACHE INTERNAL "") endif (NOT TARGET lcov-capture) # This function will add capture of coverage data for target , which is # needed to get also data for objects, which were not loaded at execution time. # It will call geninfo for every source file of once and store the info # file in the same directory. function (lcov_capture_tgt TNAME) # We don't have to check, if the target has support for coverage, thus this # will be checked by add_coverage_target in Findcoverage.cmake. Instead we # have to determine which gcov binary to use. get_target_property(TSOURCES ${TNAME} SOURCES) set(SOURCES "") set(TCOMPILER "") foreach (FILE ${TSOURCES}) codecov_path_of_source(${FILE} FILE) if (NOT "${FILE}" STREQUAL "") codecov_lang_of_source(${FILE} LANG) if (NOT "${LANG}" STREQUAL "") list(APPEND SOURCES "${FILE}") set(TCOMPILER ${CMAKE_${LANG}_COMPILER_ID}) endif () endif () endforeach () # If no gcov binary was found, coverage data can't be evaluated. if (NOT GCOV_${TCOMPILER}_BIN) message(WARNING "No coverage evaluation binary found for ${TCOMPILER}.") return() endif () set(GCOV_BIN "${GCOV_${TCOMPILER}_BIN}") set(GCOV_ENV "${GCOV_${TCOMPILER}_ENV}") get_target_property(TBIN_DIR ${TNAME} BINARY_DIR) set(TDIR ${TBIN_DIR}/CMakeFiles/${TNAME}.dir) set(GENINFO_FILES "") foreach(FILE ${SOURCES}) # Generate coverage files. If no .gcda file was generated during # execution, the empty coverage file will be used instead. set(OUTFILE "${TDIR}/${FILE}.info") list(APPEND GENINFO_FILES ${OUTFILE}) # Create an empty .gcda file, so the target capture file can have a dependency on it. # The capture file will only use this .gcda if it has a non-zero size (test -s). add_custom_command(OUTPUT "${TDIR}/${FILE}.gcda" COMMAND "${CMAKE_COMMAND}" -E touch "${TDIR}/${FILE}.gcda" ) add_custom_command(OUTPUT ${OUTFILE} COMMAND test -s "${TDIR}/${FILE}.gcda" && ${GCOV_ENV} ${GENINFO_BIN} --quiet --base-directory ${PROJECT_SOURCE_DIR} --gcov-tool ${GCOV_BIN} --output-filename ${OUTFILE} ${GENINFO_EXTERN_FLAG} ${TDIR}/${FILE}.gcda ${GENINFO_EXTRA_FLAGS} || cp ${OUTFILE}.init ${OUTFILE} DEPENDS ${TNAME} ${TNAME}-capture-init "${TDIR}/${FILE}.gcda" COMMENT "Capturing coverage data for ${FILE}" ) endforeach() # Concatenate all files generated by geninfo to a single file per target. set(OUTFILE "${LCOV_DATA_PATH_CAPTURE}/${TNAME}.info") lcov_merge_files("${OUTFILE}" ${GENINFO_FILES}) add_custom_target(${TNAME}-geninfo DEPENDS ${OUTFILE}) # add geninfo file generation to global lcov-capture target add_dependencies(lcov-capture ${TNAME}-geninfo) set(LCOV_CAPTURE_FILES "${LCOV_CAPTURE_FILES}" "${OUTFILE}" CACHE INTERNAL "" ) # Add target for generating html output for this target only. file(MAKE_DIRECTORY ${LCOV_HTML_PATH}/${TNAME}) add_custom_target(${TNAME}-genhtml COMMAND ${GENHTML_BIN} --quiet --sort ${GENHTML_CPPFILT_FLAG} --prefix ${PROJECT_SOURCE_DIR} --baseline-file ${LCOV_DATA_PATH_INIT}/${TNAME}.info --output-directory ${LCOV_HTML_PATH}/${TNAME} --title "${CMAKE_PROJECT_NAME} - target ${TNAME}" ${OUTFILE} DEPENDS ${TNAME}-geninfo ${TNAME}-capture-init ) endfunction (lcov_capture_tgt) # This function will generate the global info file for all targets. It has to be # called after all other CMake functions in the root CMakeLists.txt file, to get # a full list of all targets that generate coverage data. function (lcov_capture) # Skip this function (and do not create the following targets), if there are # no input files. if ("${LCOV_CAPTURE_FILES}" STREQUAL "") return() endif () # Add a new target to merge the files of all targets. set(OUTFILE "${LCOV_DATA_PATH_CAPTURE}/all_targets.info") lcov_merge_files("${OUTFILE}" ${LCOV_CAPTURE_FILES}) add_custom_target(lcov-geninfo DEPENDS ${OUTFILE} lcov-capture) # Add a new global target for all lcov targets. This target could be used to # generate the lcov html output for the whole project instead of calling # -geninfo and -genhtml for each target. It will also be # used to generate a html site for all project data together instead of one # for each target. if (NOT TARGET lcov) file(MAKE_DIRECTORY ${LCOV_HTML_PATH}/all_targets) add_custom_target(lcov COMMAND ${GENHTML_BIN} --quiet --sort ${GENHTML_CPPFILT_FLAG} --baseline-file ${LCOV_DATA_PATH_INIT}/all_targets.info --output-directory ${LCOV_HTML_PATH}/all_targets --title "${CMAKE_PROJECT_NAME}" --prefix "${PROJECT_SOURCE_DIR}" ${OUTFILE} DEPENDS lcov-geninfo-init lcov-geninfo ) endif () endfunction (lcov_capture) # Add a new global target to generate the lcov html report for the whole project # instead of calling -genhtml for each target (to create an own report # for each target). Instead of the lcov target it does not require geninfo for # all targets, so you have to call -geninfo to generate the info files # the targets you'd like to have in your report or lcov-geninfo for generating # info files for all targets before calling lcov-genhtml. file(MAKE_DIRECTORY ${LCOV_HTML_PATH}/selected_targets) if (NOT TARGET lcov-genhtml) add_custom_target(lcov-genhtml COMMAND ${GENHTML_BIN} --quiet --output-directory ${LCOV_HTML_PATH}/selected_targets --title \"${CMAKE_PROJECT_NAME} - targets `find ${LCOV_DATA_PATH_CAPTURE} -name \"*.info\" ! -name \"all_targets.info\" -exec basename {} .info \\\;`\" --prefix ${PROJECT_SOURCE_DIR} --sort ${GENHTML_CPPFILT_FLAG} `find ${LCOV_DATA_PATH_CAPTURE} -name \"*.info\" ! -name \"all_targets.info\"` ) endif (NOT TARGET lcov-genhtml) qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/Findcodecov.cmake000066400000000000000000000215431522610125300254240ustar00rootroot00000000000000# This file is part of CMake-codecov. # # SPDX-FileCopyrightText: RWTH Aachen University, Federal Republic of Germany # SPDX-FileContributor: Alexander Haase, alexander.haase@rwth-aachen.de # # SPDX-License-Identifier: BSD-3-Clause # Add an option to choose, if coverage should be enabled or not. If enabled # marked targets will be build with coverage support and appropriate targets # will be added. If disabled coverage will be ignored for *ALL* targets. option(ENABLE_COVERAGE "Enable coverage build." OFF) set(COVERAGE_FLAG_CANDIDATES # gcc and clang "-O0 -g -fprofile-arcs -ftest-coverage" # gcc and clang fallback "-O0 -g --coverage" ) # Add coverage support for target ${TNAME} and register target for coverage # evaluation. If coverage is disabled or not supported, this function will # simply do nothing. # # Note: This function is only a wrapper to define this function always, even if # coverage is not supported by the compiler or disabled. This function must # be defined here, because the module will be exited, if there is no coverage # support by the compiler or it is disabled by the user. function (add_coverage TNAME) # only add coverage for target, if coverage is support and enabled. if (ENABLE_COVERAGE) foreach (TNAME ${ARGV}) add_coverage_target(${TNAME}) endforeach () endif () endfunction (add_coverage) # Add global target to gather coverage information after all targets have been # added. Other evaluation functions could be added here, after checks for the # specific module have been passed. # # Note: This function is only a wrapper to define this function always, even if # coverage is not supported by the compiler or disabled. This function must # be defined here, because the module will be exited, if there is no coverage # support by the compiler or it is disabled by the user. function (coverage_evaluate) # add lcov evaluation if (LCOV_FOUND) lcov_capture_initial() lcov_capture() endif (LCOV_FOUND) endfunction () # Exit this module, if coverage is disabled. add_coverage is defined before this # return, so this module can be exited now safely without breaking any build- # scripts. if (NOT ENABLE_COVERAGE) return() endif () # Find the required flags foreach language. set(CMAKE_REQUIRED_QUIET_SAVE ${CMAKE_REQUIRED_QUIET}) set(CMAKE_REQUIRED_QUIET ${codecov_FIND_QUIETLY}) get_property(ENABLED_LANGUAGES GLOBAL PROPERTY ENABLED_LANGUAGES) foreach (LANG ${ENABLED_LANGUAGES}) if (NOT ${LANG} MATCHES "^(C|CXX|Fortran)$") message(STATUS "Skipping coverage for unsupported language: ${LANG}") continue() endif () # Coverage flags are not dependent on language, but the used compiler. So # instead of searching flags foreach language, search flags foreach compiler # used. set(COMPILER ${CMAKE_${LANG}_COMPILER_ID}) if (NOT COVERAGE_${COMPILER}_FLAGS) foreach (FLAG ${COVERAGE_FLAG_CANDIDATES}) if(NOT CMAKE_REQUIRED_QUIET) message(STATUS "Try ${COMPILER} code coverage flag = [${FLAG}]") endif() set(CMAKE_REQUIRED_FLAGS "${FLAG}") unset(COVERAGE_FLAG_DETECTED CACHE) if (${LANG} STREQUAL "C") include(CheckCCompilerFlag) check_c_compiler_flag("${FLAG}" COVERAGE_FLAG_DETECTED) elseif (${LANG} STREQUAL "CXX") include(CheckCXXCompilerFlag) check_cxx_compiler_flag("${FLAG}" COVERAGE_FLAG_DETECTED) elseif (${LANG} STREQUAL "Fortran") # CheckFortranCompilerFlag was introduced in CMake 3.x. To be # compatible with older Cmake versions, we will check if this # module is present before we use it. Otherwise we will define # Fortran coverage support as not available. include(CheckFortranCompilerFlag OPTIONAL RESULT_VARIABLE INCLUDED) if (INCLUDED) check_fortran_compiler_flag("${FLAG}" COVERAGE_FLAG_DETECTED) elseif (NOT CMAKE_REQUIRED_QUIET) message("-- Performing Test COVERAGE_FLAG_DETECTED") message("-- Performing Test COVERAGE_FLAG_DETECTED - Failed" " (Check not supported)") endif () endif() unset(CMAKE_REQUIRED_FLAGS) if (COVERAGE_FLAG_DETECTED) set(COVERAGE_${COMPILER}_FLAGS "${FLAG}" CACHE STRING "${COMPILER} flags for code coverage.") mark_as_advanced(COVERAGE_${COMPILER}_FLAGS) break() elseif (NOT CMAKE_REQUIRED_QUIET) message(WARNING "Code coverage is not available for ${COMPILER}" " compiler. Targets using this compiler will be " "compiled without it.") endif () endforeach () endif () endforeach () set(CMAKE_REQUIRED_QUIET ${CMAKE_REQUIRED_QUIET_SAVE}) # Helper function to get the language of a source file. function (codecov_lang_of_source FILE RETURN_VAR) # Usually, only the last extension of the file should be checked, to avoid # template files (i.e. *.t.cpp) are checked with the full file extension. # However, this feature requires CMake 3.14 or later. set(EXT_COMP "LAST_EXT") if(${CMAKE_VERSION} VERSION_LESS "3.14.0") set(EXT_COMP "EXT") endif() get_filename_component(FILE_EXT "${FILE}" ${EXT_COMP}) string(TOLOWER "${FILE_EXT}" FILE_EXT) string(SUBSTRING "${FILE_EXT}" 1 -1 FILE_EXT) get_property(ENABLED_LANGUAGES GLOBAL PROPERTY ENABLED_LANGUAGES) foreach (LANG ${ENABLED_LANGUAGES}) list(FIND CMAKE_${LANG}_SOURCE_FILE_EXTENSIONS "${FILE_EXT}" TEMP) if (NOT ${TEMP} EQUAL -1) set(${RETURN_VAR} "${LANG}" PARENT_SCOPE) return() endif () endforeach() set(${RETURN_VAR} "" PARENT_SCOPE) endfunction () # Helper function to get the relative path of the source file destination path. # This path is needed by FindGcov and FindLcov cmake files to locate the # captured data. function (codecov_path_of_source FILE RETURN_VAR) string(REGEX MATCH "TARGET_OBJECTS:([^ >]+)" _source ${FILE}) # If expression was found, SOURCEFILE is a generator-expression for an # object library. Currently we found no way to call this function automatic # for the referenced target, so it must be called in the directoryso of the # object library definition. if (NOT "${_source}" STREQUAL "") set(${RETURN_VAR} "" PARENT_SCOPE) return() endif () string(REPLACE "${CMAKE_CURRENT_BINARY_DIR}/" "" FILE "${FILE}") if(IS_ABSOLUTE ${FILE}) file(RELATIVE_PATH FILE ${CMAKE_CURRENT_SOURCE_DIR} ${FILE}) endif() # get the right path for file string(REPLACE ".." "__" PATH "${FILE}") set(${RETURN_VAR} "${PATH}" PARENT_SCOPE) endfunction() # Add coverage support for target ${TNAME} and register target for coverage # evaluation. function(add_coverage_target TNAME) # Check if all sources for target use the same compiler. If a target uses # e.g. C and Fortran mixed and uses different compilers (e.g. clang and # gfortran) this can trigger huge problems, because different compilers may # use different implementations for code coverage. get_target_property(TSOURCES ${TNAME} SOURCES) set(TARGET_COMPILER "") set(ADDITIONAL_FILES "") foreach (FILE ${TSOURCES}) # If expression was found, FILE is a generator-expression for an object # library. Object libraries will be ignored. string(REGEX MATCH "TARGET_OBJECTS:([^ >]+)" _file ${FILE}) if ("${_file}" STREQUAL "") codecov_lang_of_source(${FILE} LANG) if (LANG) list(APPEND TARGET_COMPILER ${CMAKE_${LANG}_COMPILER_ID}) list(APPEND ADDITIONAL_FILES "${FILE}.gcno") list(APPEND ADDITIONAL_FILES "${FILE}.gcda") endif () endif () endforeach () list(REMOVE_DUPLICATES TARGET_COMPILER) list(LENGTH TARGET_COMPILER NUM_COMPILERS) if (NUM_COMPILERS GREATER 1) message(WARNING "Can't use code coverage for target ${TNAME}, because " "it will be compiled by incompatible compilers. Target will be " "compiled without code coverage.") return() elseif (NUM_COMPILERS EQUAL 0) message(WARNING "Can't use code coverage for target ${TNAME}, because " "it uses an unknown compiler. Target will be compiled without " "code coverage.") return() elseif (NOT DEFINED "COVERAGE_${TARGET_COMPILER}_FLAGS") # A warning has been printed before, so just return if flags for this # compiler aren't available. return() endif() # enable coverage for target set_property(TARGET ${TNAME} APPEND_STRING PROPERTY COMPILE_FLAGS " ${COVERAGE_${TARGET_COMPILER}_FLAGS}") set_property(TARGET ${TNAME} APPEND_STRING PROPERTY LINK_FLAGS " ${COVERAGE_${TARGET_COMPILER}_FLAGS}") # Add gcov files generated by compiler to clean target. set(CLEAN_FILES "") foreach (FILE ${ADDITIONAL_FILES}) codecov_path_of_source(${FILE} FILE) list(APPEND CLEAN_FILES "CMakeFiles/${TNAME}.dir/${FILE}") endforeach() if(${CMAKE_VERSION} VERSION_LESS "3.15.0") set_directory_properties(PROPERTIES ADDITIONAL_MAKE_CLEAN_FILES "${CLEAN_FILES}") else() set_directory_properties(PROPERTIES ADDITIONAL_CLEAN_FILES "${CLEAN_FILES}") endif() add_gcov_target(${TNAME}) add_lcov_target(${TNAME}) endfunction(add_coverage_target) # Include modules for parsing the collected data and output it in a readable # format (like gcov and lcov). find_package(Gcov) find_package(Lcov) qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/FortranCompilerSettings.cmake000066400000000000000000000134711522610125300300310ustar00rootroot00000000000000IF (CMAKE_Fortran_COMPILER_LOADED) OPTION(FORTRAN_BOUND_CHECK "Enable the Fortran bound checker" OFF) OPTION(FORTRAN_SANITIZE "Enable the Fortran sanitizer" OFF) IF(NOT "${HOSTOPT}" STREQUAL "") IF(NOT (HOSTOPT STREQUAL OFF OR HOSTOPT STREQUAL ON)) STRING(SUBSTRING "${HOSTOPT}" 0 1 FIRST_CHAR) IF( "${FIRST_CHAR}" STREQUAL "/" ) MESSAGE(STATUS "Load user supplied Host Optimizations for Fortran -- ${HOSTOPT}") INCLUDE(${HOSTOPT}) ELSE() MESSAGE(STATUS "Load user supplied Host Optimizations for Fortran -- ${CMAKE_BINARY_DIR}/${HOSTOPT}") INCLUDE(${CMAKE_BINARY_DIR}/${HOSTOPT}) ENDIF() SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${HOSTOPT_Fortran}") ENDIF() ENDIF() INCLUDE(CheckFortranCompilerFlag_meta) FUNCTION(ADD_FORTRAN_COMPILER_FLAG VAR FLAGNAME ) SET(_SAVE ${CMAKE_REQUIRED_QUIET}) STRING(REPLACE "-" "" FLAGNAME_CLEAR "${FLAGNAME}") STRING(REPLACE "=" "" FLAGNAME_CLEAR "${FLAGNAME_CLEAR}") UNSET(_WORKS CACHE) SET(CMAKE_REQUIRED_QUIET TRUE) IF(${FLAGNAME_CLEAR}_WORKS) SET(${VAR} "${${VAR}} ${FLAGNAME}" PARENT_SCOPE) RETURN() ENDIF() CHECK_FORTRAN_COMPILER_FLAG("${FLAGNAME}" ${FLAGNAME_CLEAR}_WORKS) IF ( ${FLAGNAME_CLEAR}_WORKS) SET(${VAR} "${${VAR}} ${FLAGNAME}" PARENT_SCOPE) MESSAGE(STATUS "Fortran compiler supports ${FLAGNAME}") ELSE() MESSAGE(STATUS "Fortran compiler does not support ${FLAGNAME}") ENDIF() SET(CMAKE_REQUIRED_QUIET ${_SAVE}) ENDFUNCTION() IF(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") # GNU # Standard Flags ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-frecursive") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fPIC") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fimplicit-none") # Debug Flags ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS_DEBUG "-Wimplicit-procedure") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS_DEBUG "-Wall") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS_DEBUG "-Wunused") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS_DEBUG "-Warray-temporaries") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS_DEBUG "-fbacktrace") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS_DEBUG "-Wshadow") IF ( FORTRAN_BOUND_CHECK STREQUAL ON ) ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fcheck=bounds") ENDIF() IF ( FORTRAN_SANITIZE STREQUAL ON ) ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fcheck=all") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fsanitize=undefined") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fsanitize=address") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-fsanitize=leak") ENDIF() # Integer 8 Support IF(INTEGER8 STREQUAL ON) SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-integer-8") ENDIF() # Host optimizations IF(HOSTOPT STREQUAL ON) ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-O3") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-march=native") ADD_FORTRAN_COMPILER_FLAG(CMAKE_Fortran_FLAGS "-mtune-native") ENDIF() LIST(APPEND LIBRARIES "gfortran") ELSEIF(CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") # Intel IF ( FORTRAN_BOUND_CHECK STREQUAL ON ) SET (_BC "-check bounds") ELSE( ) SET (_BC "") ENDIF() SET(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -warn -g -warn nointerfaces ${_BC} -traceback -debug all") SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -recursive -fpic -fPIC -heap-arrays 64 ") SET(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -O3 -funroll-loops") IF(HOSTOPT STREQUAL ON) SET(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -xHost ") SET(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -xHost") ENDIF() IF(INTEGER8 STREQUAL ON) SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -i8") ENDIF() LIST(APPEND LIBRARIES "ifcore") ELSEIF(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") # PGI SET(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -O4 ") SET(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -g -Minfo=all") SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fPIC -fpic -Mnoipa") IF(INTEGER8 STREQUAL ON) SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -i8") ENDIF() STRING(REPLACE "-Mbounds" "" CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}") STRING(REPLACE "-Mipa=fast" "" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") STRING(REPLACE "-Mipa=fast" "" CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}") IF ( CMAKE_Fortran_FLAGS_DEBUG MATCHES "-Mbounds" ) STRING(REPLACE "-Mbounds" "" CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}") ENDIF() ELSEIF(CMAKE_Fortran_COMPILER_ID STREQUAL "XL") # IBM XL IF(HOSTOPT STREQUAL ON) SET(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -O5 -qessl -qhot -qtune=auto -qarch=auto -qnoipa") ELSE() SET(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -O3 -qessl -qhot -qnoipa") ENDIF() SET(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -qstrict=ieeefp -qreport -qlistfmt=html=all -qnosave -qxlf77=nopersistent") SET(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -qstrict=ieeefp -qnosave -qxlf77=nopersistent -qcheck -qsigtrap") SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qpic -qnosave -qxlf77=nopersistent -qalias=std -qnoipa -qmaxmem=32768") STRING(REPLACE "-qhalt=e" "" CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") IF(INTEGER8 STREQUAL ON) SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qintsize=8") ENDIF() IF(OPENMP_FOUND) LIST(REMOVE_ITEM CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES "xlomp_ser") ENDIF() ENDIF() ENDIF() # Compiler loaded qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/FortranModuleDir.cmake000066400000000000000000000031451522610125300264170ustar00rootroot00000000000000if(NOT DEFINED CMAKE_INSTALL_MODULEDIR) if(NOT DEFINED Fortran_MODULE_NAME) set(Fortran_MODULE_NAME ${PROJECT_NAME}) endif() set( CMAKE_INSTALL_MODULEDIR "${CMAKE_INSTALL_INCLUDEDIR}/${Fortran_MODULE_NAME}" CACHE STRING "Directory in prefix to install generated module files" ) endif() MESSAGE(STATUS "CMAKE_INSTALL_MODULEDIR: ${CMAKE_INSTALL_MODULEDIR}") if (IS_ABSOLUTE ${CMAKE_INSTALL_MODULEDIR}) set(CMAKE_INSTALL_FULL_MODULEDIR ${CMAKE_INSTALL_MODULEDIR}) else() # Handle special cases: # - CMAKE_INSTALL_PREFIX == / # - CMAKE_INSTALL_PREFIX == /usr # - CMAKE_INSTALL_PREFIX == /opt/... if("${CMAKE_INSTALL_PREFIX}" STREQUAL "/") if (NOT "${CMAKE_INSTALL_MODULEDIR}" MATCHES "^usr/") set(MODULEDIR "usr/${CMAKE_INSTALL_MODULEDIR}") endif() set(CMAKE_INSTALL_FULL_MODULEDIR "/${MODULEDIR}") elseif("${CMAKE_INSTALL_PREFIX}" MATCHES "^/usr/?$") set(CMAKE_INSTALL_FULL_MODULEDIR "${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_MODULEDIR}") elseif("${CMAKE_INSTALL_PREFIX}" MATCHES "^/opt/" AND NOT "${CMAKE_INSTALL_PREFIX}" MATCHES "^/opt/homebrew/") set(CMAKE_INSTALL_FULL_MODULEDIR "${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_MODULEDIR}") else() set(CMAKE_INSTALL_FULL_MODULEDIR "${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_MODULEDIR}") endif() endif() if(NOT IS_ABSOLUTE "${CMAKE_INSTALL_MODULEDIR}") SET(CMAKE_INSTALL_FULL_MODULEDIR "${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_MODULEDIR}") else() SET(CMAKE_INSTALL_FULL_MODULEDIR "${CMAKE_INSTALL_MODULEDIR}") endif() qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/LICENSE-CMake-codecov000066400000000000000000000030171522610125300255760ustar00rootroot00000000000000BSD 3-Clause License Copyright 2015-2025 RWTH Aachen University, Federal Republic of Germany 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 the copyright holder 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 HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/README.md000066400000000000000000000004321522610125300234500ustar00rootroot00000000000000This directory contains some CMake add-ons. The following files belong to https://github.com/RWTH-HPC/CMake-codecov and underly the licenses given in (./LICENSE-CMake-codecov)[LICENSE-CMake-codecov] * `Findcodecov.cmake` * `FindGcov.cmake` * `FindLcov.cmake` * `llvm-cov-wrapper` qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/llvm-cov-wrapper000077500000000000000000000020331522610125300253330ustar00rootroot00000000000000#!/bin/sh # This file is part of CMake-codecov. # # SPDX-FileCopyrightText: RWTH Aachen University, Federal Republic of Germany # SPDX-FileContributor: Alexander Haase, alexander.haase@rwth-aachen.de # # SPDX-License-Identifier: BSD-3-Clause if [ -z "$LLVM_COV_BIN" ] then echo "LLVM_COV_BIN not set!" >& 2 exit 1 fi # Get LLVM version to find out. LLVM_VERSION=$($LLVM_COV_BIN -version | grep -i "LLVM version" \ | sed "s/^\([A-Za-z ]*\)\([0-9]*\).\([0-9]*\).*$/\2.\3/g") if [ "$1" = "-v" ] then echo "llvm-cov-wrapper $LLVM_VERSION" exit 0 fi if [ -n "$LLVM_VERSION" ] then MAJOR=$(echo $LLVM_VERSION | cut -d'.' -f1) MINOR=$(echo $LLVM_VERSION | cut -d'.' -f2) if [ $MAJOR -eq 3 ] && [ $MINOR -le 4 ] then if [ -f "$1" ] then filename=$(basename "$1") extension="${filename##*.}" case "$extension" in "gcno") exec $LLVM_COV_BIN --gcno="$1" ;; "gcda") exec $LLVM_COV_BIN --gcda="$1" ;; esac fi fi if [ $MAJOR -eq 3 ] && [ $MINOR -le 5 ] then exec $LLVM_COV_BIN $@ fi fi exec $LLVM_COV_BIN gcov $@ qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/mingw-w32-i686.cmake000066400000000000000000000027041522610125300254230ustar00rootroot00000000000000# Sample toolchain file for building for Windows from an Ubuntu Linux system. # # Typical usage: # *) install cross compiler: `sudo apt-get install mingw-w64` or `brew install mingw-w64` on macOS # *) cmake -DCMAKE_TOOLCHAIN_FILE=~/mingw-w64-x86_64.cmake -G Ninja -B build -S . # *) ninja -C build CMAKE_MINIMUM_REQUIRED(VERSION 3.15.0) set(CMAKE_SYSTEM_NAME Windows) set(TOOLCHAIN_PREFIX i686-w64-mingw32) # cross compilers to use for C, C++ and Fortran set(CMAKE_C_COMPILER ${TOOLCHAIN_PREFIX}-gcc) set(CMAKE_CXX_COMPILER ${TOOLCHAIN_PREFIX}-g++) set(CMAKE_Fortran_COMPILER ${TOOLCHAIN_PREFIX}-gfortran) set(CMAKE_RC_COMPILER ${TOOLCHAIN_PREFIX}-windres) # target environment on the build host system set(CMAKE_FIND_ROOT_PATH /usr/${TOOLCHAIN_PREFIX} ${CMAKE_SOURCE_DIR}/tools/${TOOLCHAIN_PREFIX}) # modify default behavior of FIND_XXX() commands set(CMAKE_FIND_ROOT_PATH_MODE_PROGRAM NEVER) set(CMAKE_FIND_ROOT_PATH_MODE_LIBRARY ONLY) set(CMAKE_FIND_ROOT_PATH_MODE_INCLUDE ONLY) set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS}") set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS}") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") set(Fortran_LOCAL_FLAGS "-static") set(C_LOCAL_FLAGS "-static") set(CXX_LOCAL_FLAGS "-static") #set(CMAKE_SHARED_LINKER_FLAGS "${CMAKE_SHARED_LINKER_FLAGS} -static-libgcc -Wl,-Bstatic -lgfortran -lquadmath -Wl,-Bdynamic") #set(CMAKE_EXE_LINKER_FLAGS " -static-libgcc -Wl,-Bstatic -lgfortran -lquadmath -Wl,-Bdynamic ${CMAKE_EXE_LINKER_FLAGS} ") qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/cmake/mingw-w64-x86_64.cmake000066400000000000000000000025421522610125300256720ustar00rootroot00000000000000# Sample toolchain file for building for Windows from an Ubuntu Linux system. # # Typical usage: # *) install cross compiler: `sudo apt-get install mingw-w64` or `brew install mingw-w64` on macOS # *) cmake -DCMAKE_TOOLCHAIN_FILE=~/mingw-w64-x86_64.cmake -G Ninja -B build -S . # *) ninja -C build CMAKE_MINIMUM_REQUIRED(VERSION 3.15.0) set(CMAKE_SYSTEM_NAME Windows) set(TOOLCHAIN_PREFIX x86_64-w64-mingw32) set( CMAKE_CROSSCOMPILING_EMULATOR wine) # cross compilers to use for C, C++ and Fortran set(CMAKE_C_COMPILER ${TOOLCHAIN_PREFIX}-gcc) set(CMAKE_CXX_COMPILER ${TOOLCHAIN_PREFIX}-g++) set(CMAKE_Fortran_COMPILER ${TOOLCHAIN_PREFIX}-gfortran) set(CMAKE_RC_COMPILER ${TOOLCHAIN_PREFIX}-windres) # target environment on the build host system set(CMAKE_FIND_ROOT_PATH /usr/${TOOLCHAIN_PREFIX} ${CMAKE_SOURCE_DIR}/tools/${TOOLCHAIN_PREFIX}) # modify default behavior of FIND_XXX() commands set(CMAKE_FIND_ROOT_PATH_MODE_PROGRAM NEVER) set(CMAKE_FIND_ROOT_PATH_MODE_LIBRARY ONLY) set(CMAKE_FIND_ROOT_PATH_MODE_INCLUDE ONLY) set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} ") set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ") set(Fortran_LOCAL_FLAGS "-static") set(C_LOCAL_FLAGS "-static") set(CXX_LOCAL_FLAGS "-static") # set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -static -Os") # set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -static -Os") qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/fpm.toml000066400000000000000000000010301522610125300225630ustar00rootroot00000000000000name = "qrupdate-ng" version = "1.2.0" license = "BSD-3-clause" author = "M. Koehler, C. Himpe, Jaroslav Hajek" maintainer = "@mpimd-csc/qrupdate-ng" copyright = "Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek, Copyright (C) 2026 Martin Köhler, MPI Magdeburg" [dependencies] blas="*" [fortran] source-form = "default" implicit-external = true [build] auto-executables = false auto-tests = true auto-examples = false module-naming = "qrupdate" [library] source-dir = "src" [install] library = true qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/000077500000000000000000000000001522610125300240145ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/.gitignore000066400000000000000000000000141522610125300257770ustar00rootroot00000000000000build* *swp qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/.gitmodules000066400000000000000000000000011522610125300261600ustar00rootroot00000000000000 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/CMakeLists.txt000066400000000000000000000006341522610125300265570ustar00rootroot00000000000000PROJECT(LAPACK_MISSING Fortran) IF(${CMAKE_SOURCE_DIR} STREQUAL ${PROJECT_SOURCE_DIR}) cmake_minimum_required(VERSION 3.0) LIST(APPEND CMAKE_MODULE_PATH "${PROJECT_SOURCE_DIR}/CMakeModules") MESSAGE(STATUS "essl-lapack standalone build") FIND_PACKAGE(BLAS REQUIRED) FIND_PACKAGE(LAPACK REQUIRED) SET(LAPACK_MISSING_TARGET_NAME lapack_missing) ENDIF() INCLUDE(${CMAKE_SOURCE_DIR}/LapackMissing.cmake) qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/LICENSE000066400000000000000000000043321522610125300250230ustar00rootroot00000000000000Copyright (c) 1992-2017 The University of Tennessee and The University of Tennessee Research Foundation. All rights reserved. Copyright (c) 2000-2017 The University of California Berkeley. All rights reserved. Copyright (c) 2006-2017 The University of Colorado Denver. All rights reserved. $COPYRIGHT$ Additional copyrights may follow $HEADER$ 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 listed in this license in the documentation and/or other materials provided with the distribution. - Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. The copyright holders provide no reassurances that the source code provided does not infringe any patent, copyright, or any other intellectual property rights of third parties. The copyright holders disclaim any liability to any recipient for claims brought against recipient by any third party for infringement of that parties intellectual property rights. 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. qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/LapackMissing.cmake000066400000000000000000000217251522610125300275520ustar00rootroot00000000000000SET(CURDIR ${CMAKE_CURRENT_LIST_DIR}) INCLUDE(CheckFortranFunctionExists) IF(NOT LAPACK_MISSING_TARGET_NAME) MESSAGE(FATAL_ERROR "LAPACK_MISSING_TARGET_NAME not set.") ENDIF() IF(NOT LAPACK_MISSING_LAPACK_LIBRARIES) SET(LAPACK_MISSING_LAPACK_LIBRARIES ${LAPACK_LIBRARIES}) ENDIF() IF(NOT LAPACK_MISSING_BLAS_LIBRARIES) SET(LAPACK_MISSING_BLAS_LIBRARIES ${BLAS_LIBRARIES}) ENDIF() MACRO(CHECKLAPACKROUTINE ROUTINE VAR_TO_SET) SET(_X ${CMAKE_REQUIRED_LIBRARIES}) SET(CMAKE_REQUIRED_LIBRARIES ${LAPACK_MISSING_LAPACK_LIBRARIES} ${LAPACK_MISSING_BLAS_LIBRARIES}) CHECK_FORTRAN_FUNCTION_EXISTS(${ROUTINE} ${VAR_TO_SET}) SET(CMAKE_REQUIRED_LIBRARIES ${_X}) ENDMACRO() MACRO(ADD_LAPACK_SRC symbol) CheckLapackRoutine(${symbol} HAVE_${symbol}) IF (NOT HAVE_${symbol}) MESSAGE(STATUS "Add separate ${symbol} to library.") FOREACH(S ${ARGN}) MESSAGE(STATUS " --> src/${S}") SET(SRC ${SRC} "${CURDIR}/src/${S}") ENDFOREACH() ENDIF() SET(HAVE_${symbol} ${HAVE_${symbol}} CACHE BOOL "Lapack Symbol ${symbol} exists") ENDMACRO() SET (SRC) ADD_LAPACK_SRC(daxpby daxpby.f saxpby.f caxpby.f zaxpby.f) ADD_LAPACK_SRC(dgebak dgebak.f sgebak.f cgebak.f zggbak.f) ADD_LAPACK_SRC(dgebal dgebal.f sgebal.f cgebal.f zgebal.f) ADD_LAPACK_SRC(dgebd2 dgebd2.f sgebd2.f cgebd2.f zgebd2.f) ADD_LAPACK_SRC(dgebrd dgebrd.f sgebrd.f cgebrd.f zgebrd.f) ADD_LAPACK_SRC(dgecon dgecon.f ) ADD_LAPACK_SRC(dgees dgees.f sgees.f cgees.f zgees.f) ADD_LAPACK_SRC(dgegs dgegs.f sgegs.f cgegs.f zgegs.f) ADD_LAPACK_SRC(dgehd2 dgehd2.f sgehd2.f cgehd2.f zgehd2.f) ADD_LAPACK_SRC(dgehrd dgehrd.f sgehrd.f cgehrd.f zgehrd.f) ADD_LAPACK_SRC(dgelq2 dgelq2.f sgelq2.f cgelq2.f zgelq2.f) ADD_LAPACK_SRC(dgelqf dgelqf.f sgelqf.f cgelqf.f zgelqf.f) ADD_LAPACK_SRC(dgelqt dgelqt.f sgelqt.f cgelqt.f zgelqt.f) ADD_LAPACK_SRC(dgelqt3 dgelqt3.f sgelqt3.f cgelqt3.f zgelqt3.f) ADD_LAPACK_SRC(dgemlqt dgemlqt.f sgemlqt.f cgemlqt.f zgemlqt.f) ADD_LAPACK_SRC(dgemqr dgemqr.f sgemqr.f cgemqr.f zgemqr.f) ADD_LAPACK_SRC(dgemqrt dgemqrt.f sgemqrt.f cgemqrt.f zgemqrt.f) ADD_LAPACK_SRC(dgeqp3 dgeqp3.f sgeqp3.f cgeqp3.f zgeqp3.f) ADD_LAPACK_SRC(dgeqp3 dgeqp3.f sgeqp3.f cgeqp3.f zgeqp3.f) ADD_LAPACK_SRC(dgeqpf dgeqpf.f sgeqpf.f cgeqpf.f zgeqpf.f) ADD_LAPACK_SRC(dgeqr dgeqr.f sgeqr.f cgeqr.f zgeqr.f) ADD_LAPACK_SRC(dgeqr2 dgeqr2.f sgeqr2.f cgeqr2.f zgeqr2.f) ADD_LAPACK_SRC(dgeqrf dgeqrf.f ) ADD_LAPACK_SRC(dgeqrt dgeqrt.f sgeqrt.f cgeqrt.f zgeqrt.f) ADD_LAPACK_SRC(dgeqrt2 dgeqrt2.f sgeqrt2.f cgeqrt2.f zgeqrt2.f) ADD_LAPACK_SRC(dgeqrt3 dgeqrt3.f sgeqrt3.f cgeqrt3.f zgeqrt3.f) ADD_LAPACK_SRC(dgerq2 dgerq2.f sgerq2.f cgerq2.f zgerq2.f) ADD_LAPACK_SRC(dgerqf dgerqf.f) ADD_LAPACK_SRC(dgesc2 dgesc2.f sgesc2.f cgesc2.f zgesc2.f) ADD_LAPACK_SRC(dgetc2 dgetc2.f sgetc2.f cgetc2.f zgetc2.f) ADD_LAPACK_SRC(dggbak dggbak.f sggbak.f cggbak.f zggbak.f) ADD_LAPACK_SRC(dggbal dggbal.f sggbal.f cggbal.f zggbal.f) ADD_LAPACK_SRC(dgges dgges.f sgges.f cgges.f zgges.f) ADD_LAPACK_SRC(dgges3 dgges3.f) ADD_LAPACK_SRC(dgghd3 dgghd3.f) ADD_LAPACK_SRC(dgghrd dgghrd.f sgghrd.f cgghrd.f zgghrd.f) ADD_LAPACK_SRC(dhgeqz dhgeqz.f shgeqz.f chgeqz.f zhgeqz.f) ADD_LAPACK_SRC(dhseqr dhseqr.f shseqr.f chseqr.f zhseqr.f) ADD_LAPACK_SRC(disnan disnan.f sisnan.f) ADD_LAPACK_SRC(dlabad dlabad.f slabad.f) ADD_LAPACK_SRC(dlabrd dlabrd.f slabrd.f clabrd.f zlabrd.f) ADD_LAPACK_SRC(dlacn2 dlacn2.f slacn2.f clacn2.f zlacn2.f) ADD_LAPACK_SRC(dlacon dlacon.f slacon.f clacon.f zlacon.f) ADD_LAPACK_SRC(dlacpy dlacpy.f slacpy.f clacpy.f zlacpy.f) ADD_LAPACK_SRC(dladiv dladiv.f sladiv.f cladiv.f zladiv.f) ADD_LAPACK_SRC(dlae2 dlae2.f slae2.f) ADD_LAPACK_SRC(dlaev2 dlaev2.f slaev2.f claev2.f zlaev2.f) ADD_LAPACK_SRC(dlaexc dlaexc.f slaexc.f) ADD_LAPACK_SRC(dlag2 dlag2.f slag2.f) ADD_LAPACK_SRC(dlagv2 dlagv2.f slagv2.f ) ADD_LAPACK_SRC(dlahqr dlahqr.f slahqr.f clahqr.f zlahqr.f) ADD_LAPACK_SRC(dlahr2 dlahr2.f slahr2.f clahr2.f zlahr2.f) ADD_LAPACK_SRC(dlaic1 dlaic1.f slaic1.f claic1.f zlaic1.f) ADD_LAPACK_SRC(dlaisnan dlaisnan.f slaisnan.f) ADD_LAPACK_SRC(dlaln2 dlaln2.f slaln2.f) ADD_LAPACK_SRC(dlamch dlamch.f slamch.f) ADD_LAPACK_SRC(dlamtsqr dlamtsqr.f slamtsqr.f clamtsqr.f zlamtsqr.f) ADD_LAPACK_SRC(dlanhs dlanhs.f slanhs.f clanhs.f zlanhs.f) ADD_LAPACK_SRC(dlanst dlanst.f slanst.f) ADD_LAPACK_SRC(dlanv2 dlanv2.f slanv2.f) ADD_LAPACK_SRC(dlapy2 dlapy2.f slapy2.f slapy3.f dlapy3.f) ADD_LAPACK_SRC(dlaqp2 dlaqp2.f slaqp2.f claqp2.f zlaqp2.f) ADD_LAPACK_SRC(dlaqps dlaqps.f slaqps.f claqps.f zlaqps.f) ADD_LAPACK_SRC(dlaqr0 dlaqr0.f slaqr0.f claqr0.f zlaqr0.f) ADD_LAPACK_SRC(dlaqr1 dlaqr1.f slaqr1.f claqr1.f zlaqr1.f) ADD_LAPACK_SRC(dlaqr2 dlaqr2.f slaqr2.f claqr2.f zlaqr2.f) ADD_LAPACK_SRC(dlaqr3 dlaqr3.f slaqr3.f claqr3.f zlaqr3.f) ADD_LAPACK_SRC(dlaqr4 dlaqr4.f slaqr4.f claqr4.f zlaqr4.f) ADD_LAPACK_SRC(dlaqr5 dlaqr5.f slaqr5.f claqr5.f zlaqr5.f) ADD_LAPACK_SRC(dlarf dlarf.f slarf.f clarf.f zlarf.f) ADD_LAPACK_SRC(dlarfb dlarfb.f slarfb.f clarfb.f zlarfb.f) ADD_LAPACK_SRC(dlarfg dlarfg.f slarfg.f clarfg.f zlarfg.f) ADD_LAPACK_SRC(dlarft dlarft.f slarft.f clarft.f zlarft.f) ADD_LAPACK_SRC(dlarfx dlarfx.f slarfx.f clarfx.f zlarfx.f) ADD_LAPACK_SRC(dlarnv dlarnv.f slarnv.f clarnv.f zlarnv.f) ADD_LAPACK_SRC(dlartg dlartg.f slartg.f clartg.f zlartg.f ) ADD_LAPACK_SRC(dlaruv dlaruv.f slaruv.f) ADD_LAPACK_SRC(dlascl dlascl.f slascl.f clascl.f zlascl.f) ADD_LAPACK_SRC(dlaset dlaset.f slaset.f claset.f zlaset.f) ADD_LAPACK_SRC(dlasr dlasr.f slasr.f clasr.f zlasr.f) ADD_LAPACK_SRC(dlasrt dlasrt.f slasrt.f) ADD_LAPACK_SRC(dlassq dlassq.f slassq.f classq.f zlassq.f) ADD_LAPACK_SRC(dlasv2 dlasv2.f slasv2.f) ADD_LAPACK_SRC(dlaswp dlaswp.f slaswp.f claswp.f zlaswp.f) ADD_LAPACK_SRC(dlasy2 dlasy2.f slasy2.f) ADD_LAPACK_SRC(dlatdf dlatdf.f slatdf.f clatdf.f zlatdf.f) ADD_LAPACK_SRC(dlatrs dlatrs.f slatrs.f clatrs.f zlatrs.f) ADD_LAPACK_SRC(dlatsqr dlatsqr.f slatsqr.f clatsqr.f zlatsqr.f) ADD_LAPACK_SRC(dorg2r dorg2r.f sorg2r.f) ADD_LAPACK_SRC(dorghr dorghr.f sorghr.f) ADD_LAPACK_SRC(dorgqr dorgqr.f sorgqr.f) ADD_LAPACK_SRC(dorgr2 dorgr2.f sorgr2.f) ADD_LAPACK_SRC(dorgrq dorgrq.f) ADD_LAPACK_SRC(dorgtsqr dorgtsqr.f sorgtsqr.f cungtsqr.f zungtsqr.f) ADD_LAPACK_SRC(dorm22 dorm22.f) ADD_LAPACK_SRC(dorm2r dorm2r.f sorm2r.f) ADD_LAPACK_SRC(dormbr dormbr.f sormbr.f) ADD_LAPACK_SRC(dormhr dormhr.f sormhr.f) ADD_LAPACK_SRC(dorml2 dorml2.f sorml2.f) ADD_LAPACK_SRC(dormlq dormlq.f sormlq.f) ADD_LAPACK_SRC(dormqr dormqr.f sormqr.f) ADD_LAPACK_SRC(dormr2 dormr2.f sormr2.f) ADD_LAPACK_SRC(dormrq dormrq.f) ADD_LAPACK_SRC(dsteqr dsteqr.f ssteqr.f csteqr.f zsteqr.f) ADD_LAPACK_SRC(dtgevc dtgevc.f stgevc.f ctgevc.f ztgevc.f) ADD_LAPACK_SRC(dtgex2 dtgex2.f stgex2.f ctgex2.f ztgex2.f) ADD_LAPACK_SRC(dtgexc dtgexc.f stgexc.f ctgexc.f ztgexc.f ) ADD_LAPACK_SRC(dtgsen dtgsen.f stgsen.f ctgsen.f ztgsen.f ) ADD_LAPACK_SRC(dtgsy2 dtgsy2.f stgsy2.f ctgsy2.f ztgsy2.f) ADD_LAPACK_SRC(dtgsyl dtgsyl.f stgsyl.f ctgsyl.f ztgsyl.f) ADD_LAPACK_SRC(dtplqt dtplqt.f stplqt.f ctplqt.f ztplqt.f) ADD_LAPACK_SRC(dtplqt2 dtplqt2.f stplqt2.f ctplqt2.f ztplqt2.f) ADD_LAPACK_SRC(dtpmlqt dtpmlqt.f stpmlqt.f ctpmlqt.f ztpmlqt.f) ADD_LAPACK_SRC(dtpmqrt dtpmqrt.f stpmqrt.f ctpmqrt.f ztpmqrt.f) ADD_LAPACK_SRC(dtpqrt dtpqrt.f ctpqrt.f stpqrt.f ztpqrt.f) ADD_LAPACK_SRC(dtpqrt2 dtpqrt2.f ctpqrt2.f stpqrt2.f ztpqrt2.f) ADD_LAPACK_SRC(dtprfb dtprfb.f stprfb.f ctprfb.f ztprfb.f) ADD_LAPACK_SRC(dtrevc dtrevc.f strevc.f ctrevc.f ztrevc.f) ADD_LAPACK_SRC(dtrexc dtrexc.f strexc.f ctrexc.f ztrexc.f) ADD_LAPACK_SRC(dtrsen dtrsen.f strsen.f ctrsen.f ztrsen.f) ADD_LAPACK_SRC(dtrsyl dtrsyl.f strsyl.f ctrsyl.f ztrsyl.f) ADD_LAPACK_SRC(dtrti2 dtrti2.f strti2.f ctrti2.f ztrti2.f) ADD_LAPACK_SRC(dzsum1 dzsum1.f scsum1.f) ADD_LAPACK_SRC(ieeeck ieeeck.f ) ADD_LAPACK_SRC(iladlc iladlc.f ilaslc.f ilaclc.f ilazlc.f) ADD_LAPACK_SRC(iladlr iladlr.f ilaslr.f ilaclr.f ilazlr.f) ADD_LAPACK_SRC(ilaenv ilaenv.f ) ADD_LAPACK_SRC(iparam2stage iparam2stage.F) ADD_LAPACK_SRC(iparmq iparmq.f ) ADD_LAPACK_SRC(sdsdot sdsdot.f ) ADD_LAPACK_SRC(zlacgv zlacgv.f clacgv.f) ADD_LAPACK_SRC(zung2r zung2r.f cung2r.f) ADD_LAPACK_SRC(zunghr zunghr.f cunghr.f) ADD_LAPACK_SRC(zungqr zungqr.f cungqr.f) ADD_LAPACK_SRC(zunm2r zunm2r.f cunm2r.f) ADD_LAPACK_SRC(zunmbr zunmbr.f cunmbr.f) ADD_LAPACK_SRC(zunmqr zunmqr.f cunmqr.f) ADD_LAPACK_SRC(zunmqr zunmqr.f cunmqr.f) ADD_LAPACK_SRC(zunmr2 zunmr2.f cunmr2.f) ADD_LAPACK_SRC(zunmhr zunmhr.f cunmhr.f) ADD_LAPACK_SRC(izmax1 izmax1.f icmax1.f) ADD_LAPACK_SRC(zunmlq zunmlq.f cunmlq.f) ADD_LAPACK_SRC(zunml2 zunml2.f cunml2.f) IF(SRC) ADD_LIBRARY(${LAPACK_MISSING_TARGET_NAME} OBJECT ${SRC}) SET_TARGET_PROPERTIES(${LAPACK_MISSING_TARGET_NAME} PROPERTIES POSITION_INDEPENDENT_CODE TRUE) IF( CMAKE_Fortran_COMPILER_ID STREQUAL "XL") SET_TARGET_PROPERTIES(${LAPACK_MISSING_TARGET_NAME} PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -qfixed -qnosave") ENDIF() ENDIF() UNSET(SRC) qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/README.md000066400000000000000000000007441522610125300253000ustar00rootroot00000000000000LAPACK-MISSING ============== Copyright 2020 by Martin Koehler This library checks at compile-time if all required LAPACK routines are available and creates a small library containing the missing ones. This is required by projects that use IBM's ESSL library since this library does not contain the full set of LAPACK routines. The routines are taken from LAPACK without any modification and thus uses the same license. The cmake logic is licensed under the same terms as. qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/000077500000000000000000000000001522610125300246035ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/caxpby.f000066400000000000000000000057711522610125300262520ustar00rootroot00000000000000*> \brief \b CAXPY * * =========== DOCUMENTATION =========== * * 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 * .. * .. Array Arguments .. * COMPLEX CX(*),CY(*) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CAXPY constant times a vector plus a vector. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> number of elements in input vector(s) *> \endverbatim *> *> \param[in] CA *> \verbatim *> CA is COMPLEX *> On entry, CA specifies the scalar alpha. *> \endverbatim *> *> \param[in] CX *> \verbatim *> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> storage spacing between elements of CX *> \endverbatim *> *> \param[in,out] CY *> \verbatim *> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> storage spacing between elements of CY *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup complex_blas_level1 * *> \par Further Details: * ===================== *> *> \verbatim *> *> jack dongarra, linpack, 3/11/78. *> modified 12/3/93, array(1) declarations changed to array(*) *> \endverbatim *> * ===================================================================== SUBROUTINE CAXPBY(N,CA,CX,INCX,CB,CY,INCY) * * -- Reference BLAS level1 routine (version 3.8.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. COMPLEX CA,CB INTEGER INCX,INCY,N * .. * .. Array Arguments .. COMPLEX CX(*),CY(*) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I,IX,IY * .. * .. External Functions .. REAL SCABS1 EXTERNAL SCABS1 * .. IF (N.LE.0) RETURN IF (SCABS1(CA).EQ.0.0E+0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN * * code for both increments equal to 1 * DO I = 1,N CY(I) = CB* CY(I) + CA*CX(I) END DO ELSE * * code for unequal increments or equal increments * not equal to 1 * IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N CY(IY) = CB*CY(IY) + CA*CX(IX) IX = IX + INCX IY = IY + INCY END DO END IF * RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgebak.f000066400000000000000000000161361522610125300261750ustar00rootroot00000000000000*> \brief \b CGEBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL SCALE( * ) * COMPLEX V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEBAK forms the right or left eigenvectors of a complex general *> matrix by backward transformation on the computed eigenvectors of the *> balanced matrix output by CGEBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N', do nothing, return immediately; *> = 'P', do backward transformation for permutation only; *> = 'S', do backward transformation for scaling only; *> = 'B', do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to CGEBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by CGEBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] SCALE *> \verbatim *> SCALE is REAL array, dimension (N) *> Details of the permutation and scaling factors, as returned *> by CGEBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is COMPLEX array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by CHSEIN or CTREVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= 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 complexGEcomputational * * ===================================================================== SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. REAL SCALE( * ) COMPLEX V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K REAL S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CSSCAL, CSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL CSSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL CSSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of CGEBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgebal.f000066400000000000000000000247041522610125300261760ustar00rootroot00000000000000*> \brief \b CGEBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * REAL SCALE( * ) * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEBAL balances a general complex matrix A. This involves, first, *> permuting A by a similarity transformation to isolate eigenvalues *> in the first 1 to ILO-1 and last IHI+1 to N elements on the *> diagonal; and second, applying a diagonal similarity transformation *> to rows and columns ILO to IHI to make the rows and columns as *> close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrix, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A: *> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 *> for i = 1,...,N; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A is not referenced. *> 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] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL array, dimension (N) *> Details of the permutations and scaling factors applied to *> A. If P(j) is the index of the row and column interchanged *> with row and column j and D(j) is the scaling factor *> applied to row and column j, then *> SCALE(j) = P(j) for j = 1,...,ILO-1 *> = D(j) for j = ILO,...,IHI *> = P(j) for j = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-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 complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The permutations consist of row and column interchanges which put *> the matrix in the form *> *> ( T1 X Y ) *> P A P = ( 0 B Z ) *> ( 0 0 T2 ) *> *> where T1 and T2 are upper triangular matrices whose eigenvalues lie *> along the diagonal. The column indices ILO and IHI mark the starting *> and ending columns of the submatrix B. Balancing consists of applying *> a diagonal similarity transformation inv(D) * B * D to make the *> 1-norms of each row of B and its corresponding column nearly equal. *> The output matrix is *> *> ( T1 X*D Y ) *> ( 0 inv(D)*B*D inv(D)*Z ). *> ( 0 0 T2 ) *> *> Information about the permutations P and the diagonal matrix D is *> returned in the vector SCALE. *> *> This subroutine is based on the EISPACK routine CBAL. *> *> Modified by Tzu-Yi Chen, Computer Science Division, University of *> California at Berkeley, USA *> \endverbatim *> * ===================================================================== SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. REAL SCALE( * ) COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL SCLFAC PARAMETER ( SCLFAC = 2.0E+0 ) REAL FACTOR PARAMETER ( FACTOR = 0.95E+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 * .. * .. External Functions .. LOGICAL SISNAN, LSAME INTEGER ICAMAX REAL SLAMCH, SCNRM2 EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH, SCNRM2 * .. * .. External Subroutines .. EXTERNAL CSSCAL, CSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, MAX, MIN, REAL * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) 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( 'CGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL CSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL CSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( REAL( A( J, I ) ).NE.ZERO .OR. AIMAG( A( J, I ) ).NE. $ ZERO )GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( REAL( A( I, J ) ).NE.ZERO .OR. AIMAG( A( I, J ) ).NE. $ ZERO )GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = SLAMCH( 'S' ) / SLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L * C = SCNRM2( L-K+1, A( K, I ), 1 ) R = SCNRM2( L-K+1, A( I , K ), LDA ) ICA = ICAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = ICAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 IF( SISNAN( C+F+CA+R+G+RA ) ) THEN * * Exit if NaN to avoid infinite loop * INFO = -3 CALL XERBLA( 'CGEBAL', -INFO ) RETURN END IF F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL CSSCAL( N-K+1, G, A( I, K ), LDA ) CALL CSSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of CGEBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgebd2.f000066400000000000000000000242721522610125300261070ustar00rootroot00000000000000*> \brief \b CGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEBD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL D( * ), E( * ) * COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEBD2 reduces a complex general m by n matrix A to upper or lower *> real bidiagonal form B by a unitary transformation: Q**H * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the unitary matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the unitary matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the unitary matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the unitary matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is REAL array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is REAL array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix P. See Further Details. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (max(M,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 June 2017 * *> \ingroup complexGEcomputational * @precisions normal c -> s d z * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in *> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in *> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, v and u are complex vectors; *> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); *> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. REAL D( * ), E( * ) COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLACGV, CLARF, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 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 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'CGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * ALPHA = A( I, I ) CALL CLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = ALPHA A( I, I ) = ONE * * Apply H(i)**H to A(i:m,i+1:n) from the left * IF( I.LT.N ) $ CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL CLACGV( N-I, A( I, I+1 ), LDA ) ALPHA = A( I, I+1 ) CALL CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = ALPHA A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * CALL CLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) CALL CLACGV( N-I, A( I, I+1 ), LDA ) A( I, I+1 ) = E( I ) ELSE TAUP( I ) = ZERO END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * CALL CLACGV( N-I+1, A( I, I ), LDA ) ALPHA = A( I, I ) CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = ALPHA A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) $ CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL CLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * ALPHA = A( I+1, I ) CALL CLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Apply H(i)**H to A(i+1:m,i+1:n) from the left * CALL CLARF( 'Left', M-I, N-I, A( I+1, I ), 1, $ CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, $ WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of CGEBD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgebrd.f000066400000000000000000000257561522610125300262170ustar00rootroot00000000000000*> \brief \b CGEBRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEBRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL D( * ), E( * ) * COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEBRD reduces a general complex M-by-N matrix A to upper or lower *> bidiagonal form B by a unitary transformation: Q**H * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the M-by-N general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the unitary matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the unitary matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the unitary matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the unitary matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is REAL array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is REAL array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix P. See Further Details. *> \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 >= max(1,M,N). *> For optimum performance LWORK >= (M+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 November 2017 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in *> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in *> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. REAL D( * ), E( * ) COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX, WS * .. * .. External Subroutines .. EXTERNAL CGEBD2, CGEMM, CLABRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'CGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = REAL( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'CGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'CGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, 'CGEBRD', ' ', M, N, -1, -1 ) IF( LWORK.GE.( M+N )*NBMIN ) THEN NB = LWORK / ( M+N ) ELSE NB = 1 NX = MINMN END IF END IF END IF ELSE NX = MINMN END IF * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+ib-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * CALL CLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, $ WORK( LDWRKX*NB+1 ), LDWRKY ) * * Update the trailing submatrix A(i+ib:m,i+ib:n), using * an update of the form A := A - V*Y**H - X*U**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1, $ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA, $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, $ A( I+NB, I+NB ), LDA ) CALL CGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 10 J = I, I + NB - 1 A( J, J ) = D( J ) A( J, J+1 ) = E( J ) 10 CONTINUE ELSE DO 20 J = I, I + NB - 1 A( J, J ) = D( J ) A( J+1, J ) = E( J ) 20 CONTINUE END IF 30 CONTINUE * * Use unblocked code to reduce the remainder of the matrix * CALL CGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, IINFO ) WORK( 1 ) = WS RETURN * * End of CGEBRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgees.f000066400000000000000000000320301522610125300260360ustar00rootroot00000000000000*> \brief CGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * REAL RWORK( * ) * COMPLEX A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELECT * EXTERNAL SELECT * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEES computes for an N-by-N complex nonsymmetric matrix A, the *> eigenvalues, the Schur form T, and, optionally, the matrix of Schur *> vectors Z. This gives the Schur factorization A = Z*T*(Z**H). *> *> Optionally, it also orders the eigenvalues on the diagonal of the *> Schur form so that selected eigenvalues are at the top left. *> The leading columns of Z then form an orthonormal basis for the *> invariant subspace corresponding to the selected eigenvalues. *> *> A complex matrix is in Schur form if it is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVS *> \verbatim *> JOBVS is CHARACTER*1 *> = 'N': Schur vectors are not computed; *> = 'V': Schur vectors are computed. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the Schur form. *> = 'N': Eigenvalues are not ordered: *> = 'S': Eigenvalues are ordered (see SELECT). *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> 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. *> IF SORT = 'N', SELECT is not referenced. *> The eigenvalue W(j) is selected if SELECT(W(j)) is true. *> \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 N-by-N matrix A. *> On exit, A has been overwritten by its Schur form T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues for which *> SELECT is true. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX array, dimension (N) *> W contains the computed eigenvalues, in the same order that *> they appear on the diagonal of the output Schur form T. *> \endverbatim *> *> \param[out] VS *> \verbatim *> VS is COMPLEX array, dimension (LDVS,N) *> If JOBVS = 'V', VS contains the unitary matrix Z of Schur *> vectors. *> If JOBVS = 'N', VS is not referenced. *> \endverbatim *> *> \param[in] LDVS *> \verbatim *> LDVS is INTEGER *> The leading dimension of the array VS. LDVS >= 1; if *> JOBVS = 'V', LDVS >= 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 dimension of the array WORK. LWORK >= max(1,2*N). *> For good performance, LWORK must generally be larger. *> *> 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 (N) *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \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 i is *> <= N: the QR algorithm failed to compute all the *> eigenvalues; elements 1:ILO-1 and i+1:N of W *> contain those eigenvalues which have converged; *> if JOBVS = 'V', VS contains the matrix which *> reduces A to its partially converged Schur form. *> = N+1: the eigenvalues could not be reordered because *> some eigenvalues were too close to separate (the *> problem is very ill-conditioned); *> = N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Schur form no longer satisfy *> SELECT = .TRUE.. This could also be caused by *> underflow due to scaling. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEeigen * * ===================================================================== SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, $ LDVS, WORK, LWORK, RWORK, BWORK, 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 JOBVS, SORT INTEGER INFO, LDA, LDVS, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) REAL RWORK( * ) COMPLEX A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) * .. * .. Function Arguments .. LOGICAL SELECT EXTERNAL SELECT * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTST, WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, $ ITAU, IWRK, MAXWRK, MINWRK REAL ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM * .. * .. Local Arrays .. REAL DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY, $ CLASCL, CTRSEN, CUNGHR, SLABAD, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL CLANGE, SLAMCH EXTERNAL LSAME, ILAENV, CLANGE, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN INFO = -10 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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. * HSWORK refers to the workspace preferred by CHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 ) MINWRK = 2*N * CALL CHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS, $ WORK, -1, IEVAL ) HSWORK = WORK( 1 ) * IF( .NOT.WANTVS ) THEN MAXWRK = MAX( MAXWRK, HSWORK ) ELSE MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'CUNGHR', $ ' ', N, 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, HSWORK ) END IF END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = CLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL CLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Permute the matrix to make it more nearly triangular * (CWorkspace: none) * (RWorkspace: need N) * IBAL = 1 CALL CGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: none) * ITAU = 1 IWRK = N + ITAU CALL CGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVS ) THEN * * Copy Householder vectors to VS * CALL CLACPY( 'L', N, N, A, LDA, VS, LDVS ) * * Generate unitary matrix in VS * (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) * (RWorkspace: none) * CALL CUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) END IF * SDIM = 0 * * Perform QR iteration, accumulating Schur vectors in VS if desired * (CWorkspace: need 1, prefer HSWORK (see comments) ) * (RWorkspace: none) * IWRK = ITAU CALL CHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS, $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) IF( IEVAL.GT.0 ) $ INFO = IEVAL * * Sort eigenvalues if desired * IF( WANTST .AND. INFO.EQ.0 ) THEN IF( SCALEA ) $ CALL CLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR ) DO 10 I = 1, N BWORK( I ) = SELECT( W( I ) ) 10 CONTINUE * * Reorder eigenvalues and transform Schur vectors * (CWorkspace: none) * (RWorkspace: none) * CALL CTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM, $ S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND ) END IF * IF( WANTVS ) THEN * * Undo balancing * (CWorkspace: none) * (RWorkspace: need N) * CALL CGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS, $ IERR ) END IF * IF( SCALEA ) THEN * * Undo scaling for the Schur form of A * CALL CLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) CALL CCOPY( N, A, LDA+1, W, 1 ) END IF * WORK( 1 ) = MAXWRK RETURN * * End of CGEES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgegs.f000066400000000000000000000401661522610125300260510ustar00rootroot00000000000000*> \brief CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * REAL RWORK( * ) * COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine CGGES. *> *> CGEGS computes the eigenvalues, Schur form, and, optionally, the *> 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 *> (GNEP). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors (returned in VSL). *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors (returned in VSR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA, N) *> On entry, the matrix A. *> On exit, the upper triangular matrix S from the generalized *> Schur factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is COMPLEX array, dimension (LDB, N) *> On entry, the matrix B. *> On exit, the upper triangular matrix T from the generalized *> Schur factorization. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX array, dimension (N) *> The complex scalars alpha that define the eigenvalues of *> GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur *> form of A. *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX array, dimension (N) *> The non-negative real scalars beta that define the *> eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element *> of the triangular factor T. *> *> 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. *> Since either lambda or mu may overflow, they should not, *> in general, be computed. *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is COMPLEX array, dimension (LDVSL,N) *> If JOBVSL = 'V', the matrix of left Schur vectors Q. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >= 1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is COMPLEX array, dimension (LDVSR,N) *> If JOBVSR = 'V', the matrix of right Schur vectors Z. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. LWORK >= max(1,2*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: *> NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; *> the optimal LWORK is N*(NB+1). *> *> 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 (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> =1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHA(j) and BETA(j) should be correct for *> j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from CGGBAL *> =N+2: error return from CGEQRF *> =N+3: error return from CUNMQR *> =N+4: error return from CUNGQR *> =N+5: error return from CGGHRD *> =N+6: error return from CHGEQZ (other than failed *> iteration) *> =N+7: error return from CGGBAK (computing VSL) *> =N+8: error return from CGGBAK (computing VSR) *> =N+9: error return from CLASCL (various places) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEeigen * * ===================================================================== SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, $ VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, $ 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 JOBVSL, JOBVSR INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. REAL RWORK( * ) COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), $ WORK( * ) * .. * * ===================================================================== * * .. 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 ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, $ ILO, IRIGHT, IROWS, IRWORK, ITAU, IWORK, $ LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SAFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY, $ CLASCL, CLASET, CUNGQR, CUNMQR, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL CLANGE, SLAMCH EXTERNAL ILAENV, LSAME, CLANGE, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * * Test the input arguments * LWKMIN = MAX( 2*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -11 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -13 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -15 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'CGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'CUNMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'CUNGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = N*(NB+1) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEGS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = SLAMCH( 'E' )*SLAMCH( 'B' ) SAFMIN = SLAMCH( 'S' ) SMLNUM = N*SAFMIN / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = CLANGE( 'M', N, N, A, LDA, RWORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) THEN CALL CLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = CLANGE( 'M', N, N, B, LDB, RWORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) THEN CALL CLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * ILEFT = 1 IRIGHT = N + 1 IRWORK = IRIGHT + N IWORK = 1 CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), RWORK( IRWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 10 END IF * * Reduce B to triangular form, and initialize VSL and/or VSR * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWORK IWORK = ITAU + IROWS CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 10 END IF * CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 10 END IF * IF( ILVSL ) THEN CALL CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) CALL CUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 10 END IF END IF * IF( ILVSR ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL CGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 10 END IF * * Perform QZ algorithm, computing Schur vectors if desired * IWORK = ITAU CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWORK ), $ LWORK+1-IWORK, RWORK( IRWORK ), IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 10 END IF * * Apply permutation to VSL and VSR * IF( ILVSL ) THEN CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSL, LDVSL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 10 END IF END IF IF( ILVSR ) THEN CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 10 END IF END IF * * Undo scaling * IF( ILASCL ) THEN CALL CLASCL( 'U', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL CLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * IF( ILBSCL ) THEN CALL CLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL CLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * 10 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of CGEGS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgehd2.f000066400000000000000000000146561522610125300261220ustar00rootroot00000000000000*> \brief \b CGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEHD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGEHD2 reduces a complex general matrix A to upper Hessenberg form H *> by a unitary similarity transformation: Q**H * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to CGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= max(1,N). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the n by n general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is COMPLEX array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX 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 complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLARF, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * ALPHA = A( I+1, I ) CALL CLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL CLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i)**H to A(i+1:ihi,i+1:n) from the left * CALL CLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, $ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = ALPHA 10 CONTINUE * RETURN * * End of CGEHD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgehrd.f000066400000000000000000000252451522610125300262160ustar00rootroot00000000000000*> \brief \b CGEHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGEHRD reduces a complex general matrix A to upper Hessenberg form H by *> an unitary similarity transformation: Q**H * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to CGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is COMPLEX array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to *> zero. *> \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 >= max(1,N). *> 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 *> 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 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This file is a slight modification of LAPACK-3.0's DGEHRD *> subroutine incorporating improvements proposed by Quintana-Orti and *> Van de Geijn (2006). (See DLAHR2.) *> \endverbatim *> * ===================================================================== SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX COMPLEX EI * .. * .. External Subroutines .. EXTERNAL CAXPY, CGEHD2, CGEMM, CLAHR2, CLARFB, CTRMM, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'CGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEHRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'CGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'CGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code * IF( LWORK.LT.N*NB+TSIZE ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'CGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.(N*NBMIN+TSIZE) ) THEN NB = (LWORK-TSIZE) / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * IWT = 1 + N*NB DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V**H * which performs the reduction, and also the matrix Y = A*V*T * CALL CLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), $ WORK( IWT ), LDT, WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE 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 ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the * right * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', I, IB-1, $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) DO 30 J = 0, IB-2 CALL CAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, $ A( 1, I+J+1 ), 1 ) 30 CONTINUE * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL CLARFB( 'Left', 'Conjugate transpose', 'Forward', $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, $ WORK( IWT ), LDT, A( I+1, I+IB ), LDA, $ WORK, LDWORK ) 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL CGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = LWKOPT * RETURN * * End of CGEHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgelq2.f000066400000000000000000000121711522610125300261310ustar00rootroot00000000000000*> \brief \b CGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGELQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGELQ2 computes an LQ factorization of a complex m by n matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in *> A(i,i+1:n), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGELQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLACGV, CLARF, CLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL CLACGV( N-I+1, A( I, I ), LDA ) ALPHA = A( I, I ) CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * A( I, I ) = ONE CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), $ A( I+1, I ), LDA, WORK ) END IF A( I, I ) = ALPHA CALL CLACGV( N-I+1, A( I, I ), LDA ) 10 CONTINUE RETURN * * End of CGELQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgelqf.f000066400000000000000000000166001522610125300262160ustar00rootroot00000000000000*> \brief \b CGELQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGELQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGELQF computes an LQ factorization of a complex M-by-N matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \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. LWORK >= max(1,M). *> For optimum performance LWORK >= M*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 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in *> A(i,i+1:n), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGELQF( M, N, A, LDA, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL CGELQ2, CLARFB, CLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'CGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'CGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL CGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL CLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL CLARFB( 'Right', 'No transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL CGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of CGELQF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgelqt.f000066400000000000000000000121301522610125300262260ustar00rootroot00000000000000* * 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 June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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/MB), where each *> block is of order MB except for the last block, which is of order *> IB = K - (B-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-K 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgelqt3.f000066400000000000000000000150121522610125300263130ustar00rootroot00000000000000* 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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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, 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgemlqt.f000066400000000000000000000163301522610125300264110ustar00rootroot00000000000000* 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 *> *> CGEMLQT 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 orthogonal matrix defined as the product of K *> elementary reflectors: *> *> Q = H(1) H(2) . . . H(K) = I - V T V**H *> *> 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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,M) if SIDE = 'L', *> (LDV,N) if SIDE = 'R' *> 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. LDV >= max(1,K). *> \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-K 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**H C, C Q**H 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 November 2017 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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 * .. * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgemqr.f000066400000000000000000000172021522610125300262320ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgemqrt.f000066400000000000000000000175241522610125300264250ustar00rootroot00000000000000*> \brief \b CGEMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEMQRT overwrites the general complex 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 orthogonal matrix defined as the product of K *> elementary reflectors: *> *> Q = H(1) H(2) . . . H(K) = I - V T V**H *> *> 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CGEQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension (LDV,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRT in the first K columns 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 CGEQRT, stored as a NB-by-N matrix. *> \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, Q**H C, C Q**H 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*NB if SIDE = 'L', or M*NB 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 complexGEcomputational * * ===================================================================== SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, 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, NB, 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 ) Q = M ELSE IF ( RIGHT ) THEN LDWORK = MAX( 1, M ) Q = N 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 .OR. K.GT.Q ) THEN INFO = -5 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * 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, $ 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * 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, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * ELSE IF( RIGHT .AND. TRAN ) THEN * 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * END IF * RETURN * * End of CGEMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqp3.f000066400000000000000000000243631522610125300261440ustar00rootroot00000000000000*> \brief \b CGEQP3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEQP3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL RWORK( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGEQP3 computes a QR factorization with column pivoting of a *> matrix A: A*P = Q*R using Level 3 BLAS. *> \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 upper triangle of the array contains the *> min(M,N)-by-N upper trapezoidal matrix R; the elements below *> the diagonal, together with the array TAU, represent the *> unitary matrix Q as a product of min(M,N) elementary *> reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(J).ne.0, the J-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(J)=0, *> the J-th column of A is a free column. *> On exit, if JPVT(J)=K, then the J-th column of A*P was the *> the K-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \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. LWORK >= N+1. *> For optimal 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] RWORK *> \verbatim *> RWORK is REAL array, dimension (2*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 complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**H *> *> where tau is a complex scalar, and v is a real/complex vector *> with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in *> A(i+1:m,i), and tau in TAU(i). *> \endverbatim * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> * ===================================================================== SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ 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, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL RWORK( * ) COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN * .. * .. External Subroutines .. EXTERNAL CGEQRF, CLAQP2, CLAQPS, CSWAP, CUNMQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV REAL SCNRM2 EXTERNAL ILAENV, SCNRM2 * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test input arguments * ==================== * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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 END IF * IF( INFO.EQ.0 ) THEN MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN IWS = 1 LWKOPT = 1 ELSE IWS = N + 1 NB = ILAENV( INB, 'CGEQRF', ' ', M, N, -1, -1 ) LWKOPT = ( N + 1 )*NB END IF WORK( 1 ) = CMPLX( LWKOPT ) * IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQP3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Move initial columns up front. * NFXD = 1 DO 10 J = 1, N IF( JPVT( J ).NE.0 ) THEN IF( J.NE.NFXD ) THEN CALL CSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) JPVT( J ) = JPVT( NFXD ) JPVT( NFXD ) = J ELSE JPVT( J ) = J END IF NFXD = NFXD + 1 ELSE JPVT( J ) = J END IF 10 CONTINUE NFXD = NFXD - 1 * * Factorize fixed columns * ======================= * * Compute the QR factorization of fixed columns and update * remaining columns. * IF( NFXD.GT.0 ) THEN NA = MIN( M, NFXD ) *CC CALL CGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL CGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) IF( NA.LT.N ) THEN *CC CALL CUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, *CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, *CC $ INFO ) CALL CUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A, $ LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK, $ INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) END IF END IF * * Factorize free columns * ====================== * IF( NFXD.LT.MINMN ) THEN * SM = M - NFXD SN = N - NFXD SMINMN = MINMN - NFXD * * Determine the block size. * NB = ILAENV( INB, 'CGEQRF', ' ', SM, SN, -1, -1 ) NBMIN = 2 NX = 0 * IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( IXOVER, 'CGEQRF', ' ', SM, SN, -1, $ -1 ) ) * * IF( NX.LT.SMINMN ) THEN * * Determine if workspace is large enough for blocked code. * MINWS = ( SN+1 )*NB IWS = MAX( IWS, MINWS ) IF( LWORK.LT.MINWS ) THEN * * Not enough workspace to use optimal NB: Reduce NB and * determine the minimum value of NB. * NB = LWORK / ( SN+1 ) NBMIN = MAX( 2, ILAENV( INBMIN, 'CGEQRF', ' ', SM, SN, $ -1, -1 ) ) * * END IF END IF END IF * * Initialize partial column norms. The first N elements of work * store the exact column norms. * DO 20 J = NFXD + 1, N RWORK( J ) = SCNRM2( SM, A( NFXD+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) 20 CONTINUE * IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. $ ( NX.LT.SMINMN ) ) THEN * * Use blocked code initially. * J = NFXD + 1 * * Compute factorization: while loop. * * TOPBMN = MINMN - NX 30 CONTINUE IF( J.LE.TOPBMN ) THEN JB = MIN( NB, TOPBMN-J+1 ) * * Factorize JB columns among columns J:N. * CALL CLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, $ JPVT( J ), TAU( J ), RWORK( J ), $ RWORK( N+J ), WORK( 1 ), WORK( JB+1 ), $ N-J+1 ) * J = J + FJB GO TO 30 END IF ELSE J = NFXD + 1 END IF * * Use unblocked code to factor the last or only block. * * IF( J.LE.MINMN ) $ CALL CLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), $ TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) ) * END IF * WORK( 1 ) = CMPLX( LWKOPT ) RETURN * * End of CGEQP3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqpf.f000066400000000000000000000215021522610125300262170ustar00rootroot00000000000000*> \brief \b CGEQPF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEQPF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL RWORK( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine CGEQP3. *> *> CGEQPF computes a QR factorization with column pivoting of a *> complex M-by-N matrix A: A*P = 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. 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 upper triangle of the array contains the *> min(M,N)-by-N upper triangular matrix R; the elements *> below the diagonal, together with the array TAU, *> represent the unitary matrix Q as a product of *> min(m,n) elementary reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (N) *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is REAL array, dimension (2*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 complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(n) *> *> Each H(i) has the form *> *> H = I - tau * v * v**H *> *> where tau is a complex scalar, and v is a complex vector with *> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). *> *> The matrix P is represented in jpvt as follows: If *> jpvt(j) = i *> then the jth column of P is the ith canonical unit vector. *> *> Partial column norm updating strategy modified by *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. *> -- April 2011 -- *> For more details see LAPACK Working Note 176. *> \endverbatim *> * ===================================================================== SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, 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 * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL RWORK( * ) COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT REAL TEMP, TEMP2, TOL3Z COMPLEX AII * .. * .. External Subroutines .. EXTERNAL CGEQR2, CLARF, CLARFG, CSWAP, CUNM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, CONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SCNRM2, SLAMCH EXTERNAL ISAMAX, SCNRM2, SLAMCH * .. * .. 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQPF', -INFO ) RETURN END IF * MN = MIN( M, N ) TOL3Z = SQRT(SLAMCH('Epsilon')) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL CSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL CGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL CUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A, $ LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n elements of * work store the exact column norms. * DO 20 I = ITEMP + 1, N RWORK( I ) = SCNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) RWORK( N+I ) = RWORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + ISAMAX( N-I+1, RWORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL CSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP RWORK( PVT ) = RWORK( I ) RWORK( N+PVT ) = RWORK( N+I ) END IF * * Generate elementary reflector H(i) * AII = A( I, I ) CALL CLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) A( I, I ) = AII * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = CMPLX( ONE ) CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN * * 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( M-I.GT.0 ) THEN RWORK( J ) = SCNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) ELSE RWORK( J ) = ZERO RWORK( N+J ) = ZERO END IF ELSE RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of CGEQPF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqr.f000066400000000000000000000225061522610125300260600ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqr2.f000066400000000000000000000120331522610125300261340ustar00rootroot00000000000000*> \brief \b CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGEQR2 computes a QR factorization of a complex m by n matrix A: *> 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. 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX 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 complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGEQR2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLARF, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL CLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)**H to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of CGEQR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqrt.f000066400000000000000000000137171522610125300262500ustar00rootroot00000000000000*> \brief \b CGEQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGEQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGEQRT computes a blocked QR 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] NB *> \verbatim *> NB is INTEGER *> The block size to be used in the blocked QR. MIN(M,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 min(M,N)-by-N upper trapezoidal matrix R (R is *> upper triangular if M >= N); the elements below the diagonal *> are the columns 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 >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (NB*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 June 2017 * *> \ingroup complexGEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, IINFO, K LOGICAL USE_RECURSIVE_QR PARAMETER( USE_RECURSIVE_QR=.TRUE. ) * .. * .. External Subroutines .. EXTERNAL CGEQRT2, CGEQRT3, 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( NB.LT.1 .OR. ( NB.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.NB ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQRT', -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, 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 CALL CGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) ELSE CALL CGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) END IF IF( I+IB.LE.N ) THEN * * 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+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN * * End of CGEQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqrt2.f000066400000000000000000000141321522610125300263220ustar00rootroot00000000000000*> \brief \b CGEQRT2 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/ * *> \htmlonly *> Download CGEQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> \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 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. *> \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 complexGEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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**H *> *> where V**H is the conjugate transpose of V. *> \endverbatim *> * ===================================================================== SUBROUTINE CGEQRT2( 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, LDT, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER( ONE = (1.0,0.0), ZERO = (0.0,0.0) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX AII, ALPHA * .. * .. External Subroutines .. EXTERNAL CLARFG, CGEMV, CGERC, CTRMV, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQRT2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO I = 1, K * * Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) * CALL CLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ T( I, 1 ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(I:M,I+1:N) from the left * AII = A( I, I ) A( I, I ) = ONE * * 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, $ 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, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF END DO * DO I = 2, N AII = A( I, I ) A( I, I ) = ONE * * 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, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL CTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO * * End of CGEQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgeqrt3.f000066400000000000000000000162541522610125300263320ustar00rootroot00000000000000*> \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/ * *> \htmlonly *> Download CGEQRT3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> *> 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 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. *> \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 June 2016 * *> \ingroup complexGEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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**H *> *> where V**H is the conjugate transpose of V. *> *> For details of the algorithm, see Elmroth and Gustavson (cited above). *> \endverbatim *> * ===================================================================== RECURSIVE SUBROUTINE CGEQRT3( 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..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. COMPLEX A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = (1.0,0.0) ) * .. * .. Local Scalars .. INTEGER I, I1, J, J1, N1, N2, IINFO * .. * .. External Subroutines .. EXTERNAL CLARFG, CTRMM, CGEMM, XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N .LT. 0 ) THEN INFO = -2 ELSE IF( M .LT. N ) THEN INFO = -1 ELSE IF( LDA .LT. MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT .LT. MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEQRT3', -INFO ) RETURN END IF * IF( N.EQ.1 ) THEN * * Compute Householder transform when N=1 * CALL CLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) * ELSE * * Otherwise, split A into blocks... * N1 = N/2 N2 = N-N1 J1 = MIN( N1+1, N ) I1 = MIN( N+1, M ) * * Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1**H * CALL CGEQRT3( M, N1, A, LDA, T, LDT, IINFO ) * * Compute A(1:M,J1:N) = Q1**H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] * DO J=1,N2 DO I=1,N1 T( I, J+N1 ) = A( I, J+N1 ) END DO END DO 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, & A( J1, J1 ), LDA, ONE, T( 1, J1 ), LDT) * 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, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL CTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * DO J=1,N2 DO I=1,N1 A( I, J+N1 ) = A( I, J+N1 ) - T( I, J+N1 ) END DO END DO * * 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, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1**H Y2 T2 * DO I=1,N1 DO J=1,N2 T( I, J+N1 ) = CONJG(A( J+N1, I )) END DO END DO * 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, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), 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, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] * [ 0 R2 ] [ 0 T2] * END IF * RETURN * * End of CGEQRT3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgerq2.f000066400000000000000000000123471522610125300261440ustar00rootroot00000000000000*> \brief \b CGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGERQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CGERQ2 computes an RQ factorization of a complex m by n matrix A: *> A = R * 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,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the m by n matrix A. *> On exit, if m <= n, the upper triangle of the subarray *> A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; *> if m >= n, the elements on and above the (m-n)-th subdiagonal *> contain the m by n upper trapezoidal matrix R; the remaining *> elements, 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1)**H H(2)**H . . . H(k)**H, where k = min(m,n). *> *> 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on *> exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CGERQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLACGV, CLARF, CLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGERQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = K, 1, -1 * * Generate elementary reflector H(i) to annihilate * A(m-k+i,1:n-k+i-1) * CALL CLACGV( N-K+I, A( M-K+I, 1 ), LDA ) ALPHA = A( M-K+I, N-K+I ) CALL CLARFG( N-K+I, ALPHA, A( M-K+I, 1 ), LDA, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * A( M-K+I, N-K+I ) = ONE CALL CLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, $ TAU( I ), A, LDA, WORK ) A( M-K+I, N-K+I ) = ALPHA CALL CLACGV( N-K+I-1, A( M-K+I, 1 ), LDA ) 10 CONTINUE RETURN * * End of CGERQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgesc2.f000066400000000000000000000126151522610125300261250ustar00rootroot00000000000000*> \brief \b CGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGESC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * .. Scalar Arguments .. * INTEGER LDA, N * REAL SCALE * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * COMPLEX A( LDA, * ), RHS( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGESC2 solves a system of linear equations *> *> A * X = scale* RHS *> *> with a general N-by-N matrix A using the LU factorization with *> complete pivoting computed by CGETC2. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix A computed by CGETC2: A = P * L * U * Q *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is COMPLEX array, dimension N. *> On entry, the right hand side vector b. *> On exit, the solution vector X. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit, SCALE contains the scale factor. SCALE is chosen *> 0 <= SCALE <= 1 to prevent owerflow in the solution. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, N REAL SCALE * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) COMPLEX A( LDA, * ), RHS( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL BIGNUM, EPS, SMLNUM COMPLEX TEMP * .. * .. External Subroutines .. EXTERNAL CLASWP, CSCAL, SLABAD * .. * .. External Functions .. INTEGER ICAMAX REAL SLAMCH EXTERNAL ICAMAX, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, REAL * .. * .. Executable Statements .. * * Set constant to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) * * Apply permutations IPIV to RHS * CALL CLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) * * Solve for L part * DO 20 I = 1, N - 1 DO 10 J = I + 1, N RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) 10 CONTINUE 20 CONTINUE * * Solve for U part * SCALE = ONE * * Check for scaling * I = ICAMAX( N, RHS, 1 ) IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN TEMP = CMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) ) CALL CSCAL( N, TEMP, RHS( 1 ), 1 ) SCALE = SCALE*REAL( TEMP ) END IF DO 40 I = N, 1, -1 TEMP = CMPLX( ONE, ZERO ) / A( I, I ) RHS( I ) = RHS( I )*TEMP DO 30 J = I + 1, N RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) 30 CONTINUE 40 CONTINUE * * Apply permutations JPIV to the solution (RHS) * CALL CLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) RETURN * * End of CGESC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgetc2.f000066400000000000000000000143221522610125300261230ustar00rootroot00000000000000*> \brief \b CGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGETC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGETC2 computes an LU factorization, using complete pivoting, of the *> n-by-n matrix A. The factorization has the form A = P * L * U * Q, *> where P and Q are permutation matrices, L is lower triangular with *> unit diagonal elements and U is upper triangular. *> *> This is a level 1 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \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 n-by-n matrix to be factored. *> On exit, the factors L and U from the factorization *> A = P*L*U*Q; the unit diagonal elements of L are not stored. *> If U(k, k) appears to be less than SMIN, U(k, k) is given the *> value of SMIN, giving a nonsingular perturbed system. *> \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). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = k, U(k, k) is likely to produce overflow if *> one tries to solve for x in Ax = b. So U is perturbed *> to avoid the overflow. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complexGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, IP, IPV, J, JP, JPV REAL BIGNUM, EPS, SMIN, SMLNUM, XMAX * .. * .. External Subroutines .. EXTERNAL CGERU, CSWAP, SLABAD * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) * * Handle the case N=1 by itself * IF( N.EQ.1 ) THEN IPIV( 1 ) = 1 JPIV( 1 ) = 1 IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN INFO = 1 A( 1, 1 ) = CMPLX( SMLNUM, ZERO ) END IF RETURN END IF * * Factorize A using complete pivoting. * Set pivots less than SMIN to SMIN * DO 40 I = 1, N - 1 * * Find max element in matrix A * XMAX = ZERO DO 20 IP = I, N DO 10 JP = I, N IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( A( IP, JP ) ) IPV = IP JPV = JP END IF 10 CONTINUE 20 CONTINUE IF( I.EQ.1 ) $ SMIN = MAX( EPS*XMAX, SMLNUM ) * * Swap rows * IF( IPV.NE.I ) $ CALL CSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) IPIV( I ) = IPV * * Swap columns * IF( JPV.NE.I ) $ CALL CSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) JPIV( I ) = JPV * * Check for singularity * IF( ABS( A( I, I ) ).LT.SMIN ) THEN INFO = I A( I, I ) = CMPLX( SMIN, ZERO ) END IF DO 30 J = I + 1, N A( J, I ) = A( J, I ) / A( I, I ) 30 CONTINUE CALL CGERU( N-I, N-I, -CMPLX( ONE ), A( I+1, I ), 1, $ A( I, I+1 ), LDA, A( I+1, I+1 ), LDA ) 40 CONTINUE * IF( ABS( A( N, N ) ).LT.SMIN ) THEN INFO = N A( N, N ) = CMPLX( SMIN, ZERO ) END IF * * Set last pivots to N * IPIV( N ) = N JPIV( N ) = N * RETURN * * End of CGETC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cggbak.f000066400000000000000000000202401522610125300261660ustar00rootroot00000000000000*> \brief \b CGGBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGGBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL LSCALE( * ), RSCALE( * ) * COMPLEX V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGGBAK forms the right or left eigenvectors of a complex generalized *> eigenvalue problem A*x = lambda*B*x, by backward transformation on *> the computed eigenvectors of the balanced pair of matrices output by *> CGGBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N': do nothing, return immediately; *> = 'P': do backward transformation for permutation only; *> = 'S': do backward transformation for scaling only; *> = 'B': do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to CGGBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by CGGBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] LSCALE *> \verbatim *> LSCALE is REAL array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the left side of A and B, as returned by CGGBAL. *> \endverbatim *> *> \param[in] RSCALE *> \verbatim *> RSCALE is REAL array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the right side of A and B, as returned by CGGBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is COMPLEX array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by CTGEVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the matrix V. LDV >= 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 complexGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. Ward, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. REAL LSCALE( * ), RSCALE( * ) COMPLEX V( LDV, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CSSCAL, CSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN INFO = -4 ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) $ THEN INFO = -5 ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward transformation on right eigenvectors * IF( RIGHTV ) THEN DO 10 I = ILO, IHI CALL CSSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) 10 CONTINUE END IF * * Backward transformation on left eigenvectors * IF( LEFTV ) THEN DO 20 I = ILO, IHI CALL CSSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) 20 CONTINUE END IF END IF * * Backward permutation * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward permutation on right eigenvectors * IF( RIGHTV ) THEN IF( ILO.EQ.1 ) $ GO TO 50 DO 40 I = ILO - 1, 1, -1 K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE * 50 CONTINUE IF( IHI.EQ.N ) $ GO TO 70 DO 60 I = IHI + 1, N K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 60 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 60 CONTINUE END IF * * Backward permutation on left eigenvectors * 70 CONTINUE IF( LEFTV ) THEN IF( ILO.EQ.1 ) $ GO TO 90 DO 80 I = ILO - 1, 1, -1 K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 80 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 80 CONTINUE * 90 CONTINUE IF( IHI.EQ.N ) $ GO TO 110 DO 100 I = IHI + 1, N K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 100 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 100 CONTINUE END IF END IF * 110 CONTINUE * RETURN * * End of CGGBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cggbal.f000066400000000000000000000373611522610125300262030ustar00rootroot00000000000000*> \brief \b CGGBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGGBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL LSCALE( * ), RSCALE( * ), WORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGGBAL balances a pair of general complex matrices (A,B). This *> involves, first, permuting A and B by similarity transformations to *> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N *> elements on the diagonal; and second, applying a diagonal similarity *> transformation to rows and columns ILO to IHI to make the rows *> and columns as close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrices, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors in the *> generalized eigenvalue problem A*x = lambda*B*x. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A and B: *> = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 *> and RSCALE(I) = 1.0 for i=1,...,N; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A 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,out] B *> \verbatim *> B is COMPLEX array, dimension (LDB,N) *> On entry, the input matrix B. *> On exit, B is overwritten by the balanced matrix. *> If JOB = 'N', B is not referenced. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 and B(i,j) = 0 if i > j and *> j = 1,...,ILO-1 or i = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] LSCALE *> \verbatim *> LSCALE is REAL array, dimension (N) *> Details of the permutations and scaling factors applied *> to the left side of A and B. If P(j) is the index of the *> row interchanged with row j, and D(j) is the scaling factor *> applied to row j, then *> LSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] RSCALE *> \verbatim *> RSCALE is REAL array, dimension (N) *> Details of the permutations and scaling factors applied *> to the right side of A and B. If P(j) is the index of the *> column interchanged with column j, and D(j) is the scaling *> factor applied to column j, then *> RSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL 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 *> *> \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 complexGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. WARD, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. REAL LSCALE( * ), RSCALE( * ), WORK( * ) COMPLEX A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 ) REAL THREE, SCLFAC PARAMETER ( THREE = 3.0E+0, SCLFAC = 1.0E+1 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, $ M, NR, NRP2 REAL ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC COMPLEX CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ICAMAX REAL SDOT, SLAMCH EXTERNAL LSAME, ICAMAX, SDOT, SLAMCH * .. * .. External Subroutines .. EXTERNAL CSSCAL, CSWAP, SAXPY, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, INT, LOG10, MAX, MIN, REAL, SIGN * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGBAL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * IF( N.EQ.1 ) THEN ILO = 1 IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N DO 10 I = 1, N LSCALE( I ) = ONE RSCALE( I ) = ONE 10 CONTINUE RETURN END IF * K = 1 L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * GO TO 30 * * Permute the matrices A and B to isolate the eigenvalues. * * Find row with one nonzero in columns 1 through L * 20 CONTINUE L = LM1 IF( L.NE.1 ) $ GO TO 30 * RSCALE( 1 ) = ONE LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE LM1 = L - 1 DO 80 I = L, 1, -1 DO 40 J = 1, LM1 JP1 = J + 1 IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 50 40 CONTINUE J = L GO TO 70 * 50 CONTINUE DO 60 J = JP1, L IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 80 60 CONTINUE J = JP1 - 1 * 70 CONTINUE M = L IFLOW = 1 GO TO 160 80 CONTINUE GO TO 100 * * Find column with one nonzero in rows K through N * 90 CONTINUE K = K + 1 * 100 CONTINUE DO 150 J = K, L DO 110 I = K, LM1 IP1 = I + 1 IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 120 110 CONTINUE I = L GO TO 140 120 CONTINUE DO 130 I = IP1, L IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 150 130 CONTINUE I = IP1 - 1 140 CONTINUE M = K IFLOW = 2 GO TO 160 150 CONTINUE GO TO 190 * * Permute rows M and I * 160 CONTINUE LSCALE( M ) = I IF( I.EQ.M ) $ GO TO 170 CALL CSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) CALL CSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) * * Permute columns M and J * 170 CONTINUE RSCALE( M ) = J IF( J.EQ.M ) $ GO TO 180 CALL CSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL CSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) * 180 CONTINUE GO TO ( 20, 90 )IFLOW * 190 CONTINUE ILO = K IHI = L * IF( LSAME( JOB, 'P' ) ) THEN DO 195 I = ILO, IHI LSCALE( I ) = ONE RSCALE( I ) = ONE 195 CONTINUE RETURN END IF * IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 DO 200 I = ILO, IHI RSCALE( I ) = ZERO LSCALE( I ) = ZERO * WORK( I ) = ZERO WORK( I+N ) = ZERO WORK( I+2*N ) = ZERO WORK( I+3*N ) = ZERO WORK( I+4*N ) = ZERO WORK( I+5*N ) = ZERO 200 CONTINUE * * Compute right side vector in resulting linear equations * BASL = LOG10( SCLFAC ) DO 240 I = ILO, IHI DO 230 J = ILO, IHI IF( A( I, J ).EQ.CZERO ) THEN TA = ZERO GO TO 210 END IF TA = LOG10( CABS1( A( I, J ) ) ) / BASL * 210 CONTINUE IF( B( I, J ).EQ.CZERO ) THEN TB = ZERO GO TO 220 END IF TB = LOG10( CABS1( B( I, J ) ) ) / BASL * 220 CONTINUE WORK( I+4*N ) = WORK( I+4*N ) - TA - TB WORK( J+5*N ) = WORK( J+5*N ) - TA - TB 230 CONTINUE 240 CONTINUE * COEF = ONE / REAL( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO IT = 1 * * Start generalized conjugate gradient iteration * 250 CONTINUE * GAMMA = SDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + $ SDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) * EW = ZERO EWC = ZERO DO 260 I = ILO, IHI EW = EW + WORK( I+4*N ) EWC = EWC + WORK( I+5*N ) 260 CONTINUE * GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC-THREE*EW ) TC = COEF5*( EW-THREE*EWC ) * CALL SSCAL( NR, BETA, WORK( ILO ), 1 ) CALL SSCAL( NR, BETA, WORK( ILO+N ), 1 ) * CALL SAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) CALL SAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) * DO 270 I = ILO, IHI WORK( I ) = WORK( I ) + TC WORK( I+N ) = WORK( I+N ) + T 270 CONTINUE * * Apply matrix to vector * DO 300 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 290 J = ILO, IHI IF( A( I, J ).EQ.CZERO ) $ GO TO 280 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 280 CONTINUE IF( B( I, J ).EQ.CZERO ) $ GO TO 290 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 290 CONTINUE WORK( I+2*N ) = REAL( KOUNT )*WORK( I+N ) + SUM 300 CONTINUE * DO 330 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 320 I = ILO, IHI IF( A( I, J ).EQ.CZERO ) $ GO TO 310 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 310 CONTINUE IF( B( I, J ).EQ.CZERO ) $ GO TO 320 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 320 CONTINUE WORK( J+3*N ) = REAL( KOUNT )*WORK( J ) + SUM 330 CONTINUE * SUM = SDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + $ SDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) ALPHA = GAMMA / SUM * * Determine correction to current iteration * CMAX = ZERO DO 340 I = ILO, IHI COR = ALPHA*WORK( I+N ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR COR = ALPHA*WORK( I ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( I ) = RSCALE( I ) + COR 340 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 350 * CALL SAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) CALL SAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) * PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 250 * * End generalized conjugate gradient iteration * 350 CONTINUE SFMIN = SLAMCH( 'S' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) DO 360 I = ILO, IHI IRAB = ICAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) IRAB = ICAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR ICAB = ICAMAX( IHI, A( 1, I ), 1 ) CAB = ABS( A( ICAB, I ) ) ICAB = ICAMAX( IHI, B( 1, I ), 1 ) CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( I ) = SCLFAC**JC 360 CONTINUE * * Row scaling of matrices A and B * DO 370 I = ILO, IHI CALL CSSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) CALL CSSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) 370 CONTINUE * * Column scaling of matrices A and B * DO 380 J = ILO, IHI CALL CSSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) CALL CSSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) 380 CONTINUE * RETURN * * End of CGGBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgges.f000066400000000000000000000454271522610125300260560ustar00rootroot00000000000000*> \brief CGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGGES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * REAL RWORK( * ) * COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGGES computes for a pair of N-by-N complex nonsymmetric matrices *> (A,B), the generalized eigenvalues, the generalized complex Schur *> form (S, T), and optionally left and/or right Schur vectors (VSL *> and VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) *> *> where (VSR)**H is the conjugate-transpose of VSR. *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> triangular matrix S and the upper triangular matrix T. The leading *> columns of VSL and VSR then form an unitary basis for the *> corresponding left and right eigenspaces (deflating subspaces). *> *> (If only the generalized eigenvalues are needed, use the driver *> CGGEV instead, which is faster.) *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0, and even for both being zero. *> *> A pair of matrices (S,T) is in generalized complex Schur form if S *> and T are upper triangular and, in addition, the diagonal elements *> of T are non-negative real numbers. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG). *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of two COMPLEX arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue ALPHA(j)/BETA(j) is selected if *> SELCTG(ALPHA(j),BETA(j)) is true. *> *> Note that a selected complex eigenvalue may no longer satisfy *> SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since *> ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned), in this *> case INFO is set to N+2 (See INFO below). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is COMPLEX array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX array, dimension (N) *> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the *> generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), *> j=1,...,N are the diagonals of the complex Schur form (A,B) *> output by CGGES. The BETA(j) will be non-negative real. *> *> Note: the quotients ALPHA(j)/BETA(j) may easily over- or *> underflow, and BETA(j) may even be zero. Thus, the user *> should avoid naively computing the ratio alpha/beta. *> However, ALPHA will be always less than and usually *> comparable with norm(A) in magnitude, and BETA always less *> than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is COMPLEX array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >= 1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is COMPLEX array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. LWORK >= max(1,2*N). *> For good performance, LWORK must generally be larger. *> *> 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 (8*N) *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> =1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHA(j) and BETA(j) should be correct for *> j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in CHGEQZ *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in CTGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEeigen * * ===================================================================== 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.7.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 JOBVSL, JOBVSR, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) REAL RWORK( * ) COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), $ WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. 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 CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN, $ LWKOPT REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, $ PVSR, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) REAL DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY, $ CLASCL, CLASET, CTGSEN, CUNGQR, CUNMQR, SLABAD, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL CLANGE, SLAMCH EXTERNAL LSAME, ILAENV, CLANGE, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -14 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -16 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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.) * IF( INFO.EQ.0 ) THEN 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, -1 ) ) IF( ILVSL ) THEN LWKOPT = MAX( LWKOPT, N + $ N*ILAENV( 1, 'CUNGQR', ' ', N, 1, N, -1 ) ) END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) $ INFO = -18 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = CLANGE( 'M', N, N, A, LDA, RWORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) $ CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = CLANGE( 'M', N, N, B, LDB, RWORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) $ CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * (Real Workspace: need 6*N) * ILEFT = 1 IRIGHT = N + 1 IRWRK = IRIGHT + N CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Complex Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = 1 IWRK = ITAU + IROWS CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Complex Workspace: need N, prefer N*NB) * CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * (Complex Workspace: need N, prefer N*NB) * IF( ILVSL ) THEN CALL CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL CUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * CALL CGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IERR ) * SDIM = 0 * * Perform QZ algorithm, computing Schur vectors if desired * (Complex Workspace: need N) * (Real Workspace: need N) * IWRK = ITAU CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ), $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 30 END IF * * Sort eigenvalues ALPHA/BETA if desired * (Workspace: none needed) * IF( WANTST ) THEN * * Undo scaling on eigenvalues before selecting * IF( ILASCL ) $ CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR ) IF( ILBSCL ) $ CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) ) 10 CONTINUE * CALL CTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA, $ BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR, $ DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR ) IF( IERR.EQ.1 ) $ INFO = N + 3 * END IF * * Apply back-permutation to VSL and VSR * (Workspace: none needed) * IF( ILVSL ) $ CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSL, LDVSL, IERR ) IF( ILVSR ) $ CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSR, LDVSR, IERR ) * * Undo scaling * IF( ILASCL ) THEN CALL CLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) END IF * IF( ILBSCL ) THEN CALL CLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. SDIM = 0 DO 20 I = 1, N CURSL = SELCTG( ALPHA( I ), BETA( I ) ) IF( CURSL ) $ SDIM = SDIM + 1 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 LASTSL = CURSL 20 CONTINUE * END IF * 30 CONTINUE * WORK( 1 ) = LWKOPT * RETURN * * End of CGGES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cgghrd.f000066400000000000000000000251601522610125300262140ustar00rootroot00000000000000*> \brief \b CGGHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CGGHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CGGHRD reduces a pair of complex matrices (A,B) to generalized upper *> Hessenberg form using unitary transformations, where A is a *> general matrix and B is upper triangular. The form of the generalized *> eigenvalue problem is *> A*x = lambda*B*x, *> and B is typically made upper triangular by computing its QR *> factorization and moving the unitary matrix Q to the left side *> of the equation. *> *> This subroutine simultaneously reduces A to a Hessenberg matrix H: *> Q**H*A*Z = H *> and transforms B to another upper triangular matrix T: *> Q**H*B*Z = T *> in order to reduce the problem to its standard form *> H*y = lambda*T*y *> where y = Z**H*x. *> *> The unitary matrices Q and Z are determined as products of Givens *> rotations. They may either be formed explicitly, or they may be *> postmultiplied into input matrices Q1 and Z1, so that *> Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H *> Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H *> If Q1 is the unitary matrix from the QR factorization of B in the *> original equation A*x = lambda*B*x, then CGGHRD reduces the original *> problem to generalized Hessenberg form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': do not compute Q; *> = 'I': Q is initialized to the unit matrix, and the *> unitary matrix Q is returned; *> = 'V': Q must contain a unitary matrix Q1 on entry, *> and the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': do not compute Z; *> = 'I': Z is initialized to the unit matrix, and the *> unitary matrix Z is returned; *> = 'V': Z must contain a unitary matrix Z1 on entry, *> and the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI mark the rows and columns of A which are to be *> reduced. It is assumed that A is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are *> normally set by a previous call to CGGBAL; otherwise they *> should be set to 1 and N respectively. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA, N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, and the *> rest is set to zero. *> \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 N-by-N upper triangular matrix B. *> On exit, the upper triangular matrix T = Q**H B Z. The *> elements below the diagonal are set to zero. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the unitary matrix Q1, typically *> from the QR factorization of B. *> On exit, if COMPQ='I', the unitary matrix Q, and if *> COMPQ = 'V', the product Q1*Q. *> Not referenced if COMPQ='N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the unitary matrix Z1. *> On exit, if COMPZ='I', the unitary matrix Z, and if *> COMPZ = 'V', the product Z1*Z. *> Not referenced if COMPZ='N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. *> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. *> \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 *> *> This routine reduces A to Hessenberg and B to triangular form by *> an unblocked reduction, as described in _Matrix_Computations_, *> by Golub and van Loan (Johns Hopkins Press). *> \endverbatim *> * ===================================================================== SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, 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 COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX CONE, CZERO PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL ILQ, ILZ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW REAL C COMPLEX CTEMP, S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLARTG, CLASET, CROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Decode COMPQ * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * * Decode COMPZ * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Test the input parameters. * INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGHRD', -INFO ) RETURN END IF * * Initialize Q and Z if desired. * IF( ICOMPQ.EQ.3 ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Zero out lower triangle of B * DO 20 JCOL = 1, N - 1 DO 10 JROW = JCOL + 1, N B( JROW, JCOL ) = CZERO 10 CONTINUE 20 CONTINUE * * Reduce A and B * DO 40 JCOL = ILO, IHI - 2 * DO 30 JROW = IHI, JCOL + 2, -1 * * Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) * CTEMP = A( JROW-1, JCOL ) CALL CLARTG( CTEMP, A( JROW, JCOL ), C, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = CZERO CALL CROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, C, S ) CALL CROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, $ B( JROW, JROW-1 ), LDB, C, S ) IF( ILQ ) $ CALL CROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, $ CONJG( S ) ) * * Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) * CTEMP = B( JROW, JROW ) CALL CLARTG( CTEMP, B( JROW, JROW-1 ), C, S, $ B( JROW, JROW ) ) B( JROW, JROW-1 ) = CZERO CALL CROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) CALL CROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, $ S ) IF( ILZ ) $ CALL CROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) 30 CONTINUE 40 CONTINUE * RETURN * * End of CGGHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/chgeqz.f000066400000000000000000000673721522610125300262520ustar00rootroot00000000000000*> \brief \b CHGEQZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CHGEQZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * REAL RWORK( * ) * COMPLEX ALPHA( * ), BETA( * ), H( LDH, * ), * $ Q( LDQ, * ), T( LDT, * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), *> where H is an upper Hessenberg matrix and T is upper triangular, *> 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. *> If Q1 and Z1 are the unitary matrices from CGGHRD that reduced *> 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 *> eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) *> A*x = lambda*B*x *> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the *> alternate form of the GNEP *> mu*A*y = B*y. *> The values of alpha and beta for the i-th eigenvalue can be read *> directly from the generalized Schur form: alpha = S(i,i), *> beta = P(i,i). *> *> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix *> Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), *> pp. 241--256. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; *> = 'S': Computer eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': Left Schur vectors (Q) are not computed; *> = 'I': Q is initialized to the unit matrix and the matrix Q *> of left Schur vectors of (H,T) is returned; *> = 'V': Q must contain a unitary matrix Q1 on entry and *> the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Right Schur vectors (Z) are not computed; *> = 'I': Q is initialized to the unit matrix and the matrix Z *> of right Schur vectors of (H,T) is returned; *> = 'V': Z must contain a unitary matrix Z1 on entry and *> the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices H, T, Q, and Z. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI mark the rows and columns of H which are in *> Hessenberg form. It is assumed that A is already upper *> triangular in rows and columns 1:ILO-1 and IHI+1:N. *> If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH, N) *> On entry, the N-by-N upper Hessenberg matrix H. *> On exit, if JOB = 'S', H contains the upper triangular *> matrix S from the generalized Schur factorization. *> If JOB = 'E', the diagonal of H matches that of S, but *> the rest of H is unspecified. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max( 1, N ). *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is COMPLEX array, dimension (LDT, N) *> On entry, the N-by-N upper triangular matrix T. *> On exit, if JOB = 'S', T contains the upper triangular *> matrix P from the generalized Schur factorization. *> If JOB = 'E', the diagonal of T matches that of P, but *> the rest of T is unspecified. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max( 1, N ). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX array, dimension (N) *> The complex scalars alpha that define the eigenvalues of *> GNEP. ALPHA(i) = S(i,i) in the generalized Schur *> factorization. *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX array, dimension (N) *> The real non-negative scalars beta that define the *> eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized *> Schur factorization. *> *> 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. *> Since either lambda or mu may overflow, they should not, *> in general, be computed. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the unitary matrix Q1 used in the *> reduction of (A,B) to generalized Hessenberg form. *> 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 COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If COMPQ='V' or 'I', then LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the unitary matrix Z1 used in the *> reduction of (A,B) to generalized Hessenberg form. *> On exit, if COMPZ = 'I', the unitary matrix of right Schur *> vectors of (H,T), and if COMPZ = 'V', the unitary matrix of *> right Schur vectors of (A,B). *> Not referenced if COMPZ = 'N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If COMPZ='V' or 'I', then LDZ >= 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 dimension of the array WORK. LWORK >= max(1,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] RWORK *> \verbatim *> RWORK is REAL 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 *> = 1,...,N: the QZ iteration did not converge. (H,T) is not *> in Schur form, but ALPHA(i) and BETA(i), *> i=INFO+1,...,N should be correct. *> = N+1,...,2*N: the shift calculation failed. (H,T) is not *> in Schur form, but ALPHA(i) and BETA(i), *> i=INFO-N+1,...,N should be correct. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We assume that complex ABS works as long as its value is less than *> overflow. *> \endverbatim *> * ===================================================================== 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.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 COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. REAL RWORK( * ) COMPLEX ALPHA( * ), BETA( * ), H( LDH, * ), $ Q( LDQ, * ), T( LDT, * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. 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 ) REAL HALF PARAMETER ( HALF = 0.5E+0 ) * .. * .. Local Scalars .. LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT REAL ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ U12, X * .. * .. External Functions .. LOGICAL LSAME REAL CLANHS, SLAMCH EXTERNAL LSAME, CLANHS, SLAMCH * .. * .. External Subroutines .. EXTERNAL CLARTG, CLASET, CROT, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL, SQRT * .. * .. Statement Functions .. REAL ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) ) * .. * .. Executable Statements .. * * Decode JOB, COMPQ, COMPZ * IF( LSAME( JOB, 'E' ) ) THEN ILSCHR = .FALSE. ISCHUR = 1 ELSE IF( LSAME( JOB, 'S' ) ) THEN ILSCHR = .TRUE. ISCHUR = 2 ELSE ISCHUR = 0 END IF * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Check Argument Values * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.EQ.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 ) THEN INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE IF( LDH.LT.N ) THEN INFO = -8 ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -16 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -18 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CHGEQZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * * WORK( 1 ) = CMPLX( 1 ) IF( N.LE.0 ) THEN WORK( 1 ) = CMPLX( 1 ) RETURN END IF * * Initialize Q and Z * IF( ICOMPQ.EQ.3 ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * * Machine Constants * IN = IHI + 1 - ILO SAFMIN = SLAMCH( 'S' ) ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) ANORM = CLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) BNORM = CLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) BSCALE = ONE / MAX( SAFMIN, BNORM ) * * * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN SIGNBC = CONJG( T( J, J ) / ABSB ) T( J, J ) = ABSB IF( ILSCHR ) THEN CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 ) CALL CSCAL( J, SIGNBC, H( 1, J ), 1 ) ELSE CALL CSCAL( 1, SIGNBC, H( J, J ), 1 ) END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE T( J, J ) = CZERO END IF ALPHA( J ) = H( J, J ) BETA( J ) = T( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps * IF( IHI.LT.ILO ) $ GO TO 190 * * MAIN QZ ITERATION LOOP * * Initialize dynamic indices * * Eigenvalues ILAST+1:N have been found. * Column operations modify rows IFRSTM:whatever * Row operations modify columns whatever:ILASTM * * If only eigenvalues are being computed, then * IFRSTM is the row of the last splitting row above row ILAST; * this is always at least ILO. * IITER counts iterations since the last eigenvalue was found, * to tell when to use an extraordinary shift. * MAXIT is the maximum number of QZ sweeps allowed. * ILAST = IHI IF( ILSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ESHIFT = CZERO MAXIT = 30*( IHI-ILO+1 ) * DO 170 JITER = 1, MAXIT * * Check for too many iterations. * IF( JITER.GT.MAXIT ) $ GO TO 180 * * Split the matrix if possible. * * Two tests: * 1: H(j,j-1)=0 or j=ILO * 2: T(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN H( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN T( ILAST, ILAST ) = CZERO GO TO 50 END IF * * General case: j \brief \b CHSEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CHSEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CHSEQR computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**H, where T is an upper triangular matrix (the *> Schur form), and Z is the unitary matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': compute eigenvalues only; *> = 'S': compute eigenvalues and the Schur form T. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': no Schur vectors are computed; *> = 'I': Z is initialized to the unit matrix and the matrix Z *> of Schur vectors of H is returned; *> = 'V': Z must contain an unitary matrix Q on entry, and *> the product Q*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to CGEBAL, and then passed to ZGEHRD *> when the matrix output by CGEBAL is reduced to Hessenberg *> form. Otherwise ILO and IHI should be set to 1 and N *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and JOB = 'S', H contains the upper *> triangular matrix T from the Schur decomposition (the *> Schur form). If INFO = 0 and JOB = 'E', the contents of *> H are unspecified on exit. (The output value of H when *> INFO.GT.0 is given under the description of INFO below.) *> *> Unlike earlier versions of CHSEQR, this subroutine may *> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 *> or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX array, dimension (N) *> The computed eigenvalues. If JOB = 'S', the eigenvalues are *> stored in the same order as on the diagonal of the Schur *> form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,N) *> If COMPZ = 'N', Z is not referenced. *> If COMPZ = 'I', on entry Z need not be set and on exit, *> if INFO = 0, Z contains the unitary matrix Z of the Schur *> vectors of H. If COMPZ = 'V', on entry Z must contain an *> N-by-N matrix Q, which is assumed to be equal to the unit *> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, *> if INFO = 0, Z contains Q*Z. *> Normally Q is the unitary matrix generated by CUNGHR *> after the call to CGEHRD which formed the Hessenberg matrix *> H. (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if COMPZ = 'I' or *> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient and delivers very good and sometimes *> optimal performance. However, LWORK as large as 11*N *> may be required for optimal performance. A workspace *> query is recommended to determine the optimal workspace *> size. *> *> If LWORK = -1, then CHSEQR does a workspace query. *> In this case, CHSEQR checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .LT. 0: if INFO = -i, the i-th argument had an illegal *> value *> .GT. 0: if INFO = i, CHSEQR failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and JOB = 'E', then on exit, the *> remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and JOB = 'S', then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a unitary matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and COMPZ = 'V', then on exit *> *> (final value of Z) = (initial value of Z)*U *> *> where U is the unitary matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'I', then on exit *> (final value of Z) = U *> where U is the unitary matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'N', then Z is not *> accessed. *> \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 Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> Default values supplied by *> ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). *> It is suggested that these defaults be adjusted in order *> to attain best performance in each particular *> computational environment. *> *> ISPEC=12: The CLAHQR vs CLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> ISPEC=13: Recommended deflation window size. *> This depends on ILO, IHI and NS. NS is the *> number of simultaneous shifts returned *> by ILAENV(ISPEC=15). (See ISPEC=15 below.) *> The default for (IHI-ILO+1).LE.500 is NS. *> The default for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> ISPEC=14: Nibble crossover point. (See IPARMQ for *> details.) Default: 14% of deflation window *> size. *> *> ISPEC=15: Number of simultaneous shifts in a multishift *> QR iteration. *> *> If IHI-ILO+1 is ... *> *> greater than ...but less ... the *> or equal to ... than default is *> *> 1 30 NS = 2(+) *> 30 60 NS = 4(+) *> 60 150 NS = 10(+) *> 150 590 NS = ** *> 590 3000 NS = 64 *> 3000 6000 NS = 128 *> 6000 infinity NS = 256 *> *> (+) By default some or all matrices of this order *> are passed to the implicit double shift routine *> CLAHQR and this parameter is ignored. See *> ISPEC=12 above and comments in IPARMQ for *> details. *> *> (**) The asterisks (**) indicate an ad-hoc *> function of N increasing from 10 to 64. *> *> ISPEC=16: Select structured matrix multiply. *> If the number of simultaneous shifts (specified *> by ISPEC=15) is less than 14, then the default *> for ISPEC=16 is 0. Otherwise the default for *> ISPEC=16 is 2. *> \endverbatim * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. * * ===================================================================== SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ 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 IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . CLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare CLAHQR failure. NL .GT. NTINY = 11 is * . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== INTEGER NL PARAMETER ( NL = 49 ) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0e0 ) * .. * .. Local Arrays .. COMPLEX HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. INTEGER KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. INTEGER ILAENV LOGICAL LSAME EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL CCOPY, CLACPY, CLAHQR, CLAQR0, CLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Executable Statements .. * * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) WORK( 1 ) = CMPLX( REAL( MAX( 1, N ) ), RZERO ) LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN * * ==== Quick return in case of invalid argument. ==== * CALL XERBLA( 'CHSEQR', -INFO ) RETURN * ELSE IF( N.EQ.0 ) THEN * * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ELSE IF( LQUERY ) THEN * * ==== Quick return in case of a workspace query ==== * CALL CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, $ LDZ, WORK, LWORK, INFO ) * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== WORK( 1 ) = CMPLX( MAX( REAL( WORK( 1 ) ), REAL( MAX( 1, $ N ) ) ), RZERO ) RETURN * ELSE * * ==== copy eigenvalues isolated by CGEBAL ==== * IF( ILO.GT.1 ) $ CALL CCOPY( ILO-1, H, LDH+1, W, 1 ) IF( IHI.LT.N ) $ CALL CCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) * * ==== Initialize Z, if requested ==== * IF( INITZ ) $ CALL CLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * * ==== Quick return if possible ==== * IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * * ==== CLAHQR/CLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'CHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== CLAQR0 for big matrices; CLAHQR for small ones ==== * IF( N.GT.NMIN ) THEN CALL CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, $ Z, LDZ, WORK, LWORK, INFO ) ELSE * * ==== Small matrix ==== * CALL CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, $ Z, LDZ, INFO ) * IF( INFO.GT.0 ) THEN * * ==== A rare CLAHQR failure! CLAQR0 sometimes succeeds * . when CLAHQR fails. ==== * KBOT = INFO * IF( N.GE.NL ) THEN * * ==== Larger matrices have enough subdiagonal scratch * . space to call CLAQR0 directly. ==== * CALL CLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ELSE * * ==== Tiny matrices don't have enough subdiagonal * . scratch space to benefit from CLAQR0. Hence, * . tiny matrices must be copied into a larger * . array before calling CLAQR0. ==== * CALL CLACPY( 'A', N, N, H, LDH, HL, NL ) HL( N+1, N ) = ZERO CALL CLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), $ NL ) CALL CLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) IF( WANTT .OR. INFO.NE.0 ) $ CALL CLACPY( 'A', N, N, HL, NL, H, LDH ) END IF END IF END IF * * ==== Clear out the trash, if necessary. ==== * IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) $ CALL CLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== * WORK( 1 ) = CMPLX( MAX( REAL( MAX( 1, N ) ), $ REAL( WORK( 1 ) ) ), RZERO ) END IF * * ==== End of CHSEQR ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clabrd.f000066400000000000000000000357161522610125300262150ustar00rootroot00000000000000*> \brief \b CLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLABRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL D( * ), E( * ) * COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), * $ Y( LDY, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLABRD reduces the first NB rows and columns of a complex general *> m by n matrix A to upper or lower real bidiagonal form by a unitary *> transformation Q**H * A * P, and returns the matrices X and Y which *> are needed to apply the transformation to the unreduced part of A. *> *> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower *> bidiagonal form. *> *> This is an auxiliary routine called by CGEBRD *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of leading rows and columns of A to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, the first NB rows and columns of the matrix are *> overwritten; the rest of the array is unchanged. *> If m >= n, elements on and below the diagonal in the first NB *> columns, with the array TAUQ, represent the unitary *> matrix Q as a product of elementary reflectors; and *> elements above the diagonal in the first NB rows, with the *> array TAUP, represent the unitary matrix P as a product *> of elementary reflectors. *> If m < n, elements below the diagonal in the first NB *> columns, with the array TAUQ, represent the unitary *> matrix Q as a product of elementary reflectors, and *> elements on and above the diagonal in the first NB rows, *> with the array TAUP, represent the unitary matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is REAL array, dimension (NB) *> The diagonal elements of the first NB rows and columns of *> the reduced matrix. D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is REAL array, dimension (NB) *> The off-diagonal elements of the first NB rows and columns of *> the reduced matrix. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is COMPLEX array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is COMPLEX array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix P. See Further Details. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is COMPLEX array, dimension (LDX,NB) *> The m-by-nb matrix X required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,M). *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is COMPLEX array, dimension (LDY,NB) *> The n-by-nb matrix Y required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors. *> *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in *> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The elements of the vectors v and u together form the m-by-nb matrix *> V and the nb-by-n matrix U**H which are needed, with X and Y, to apply *> the transformation to the unreduced part of the matrix, using a block *> update of the form: A := A - V*Y**H - X*U**H. *> *> The contents of A on exit are illustrated by the following examples *> with nb = 2: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) *> ( v1 v2 a a a ) ( v1 1 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix which is unchanged, *> vi denotes an element of the vector defining H(i), and ui an element *> of the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. REAL D( * ), E( * ) COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), $ Y( LDY, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CGEMV, CLACGV, CLARFG, CSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL CLACGV( I-1, Y( I, 1 ), LDY ) CALL CGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) CALL CLACGV( I-1, Y( I, 1 ), LDY ) CALL CGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+1:m,i) * ALPHA = A( I, I ) CALL CLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = ALPHA IF( I.LT.N ) THEN A( I, I ) = ONE * * Compute Y(i+1:n,i) * CALL CGEMV( 'Conjugate transpose', M-I+1, N-I, ONE, $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ A( I, 1 ), LDA, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL CGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ X( I, 1 ), LDX, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL CLACGV( N-I, A( I, I+1 ), LDA ) CALL CLACGV( I, A( I, 1 ), LDA ) CALL CGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) CALL CLACGV( I, A( I, 1 ), LDA ) CALL CLACGV( I-1, X( I, 1 ), LDX ) CALL CGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE, $ A( I, I+1 ), LDA ) CALL CLACGV( I-1, X( I, 1 ), LDX ) * * Generate reflection P(i) to annihilate A(i,i+2:n) * ALPHA = A( I, I+1 ) CALL CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = ALPHA A( I, I+1 ) = ONE * * Compute X(i+1:m,i) * CALL CGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', N-I, I, ONE, $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO, $ X( 1, I ), 1 ) CALL CGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL CGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL CGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL CLACGV( N-I, A( I, I+1 ), LDA ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL CLACGV( N-I+1, A( I, I ), LDA ) CALL CLACGV( I-1, A( I, 1 ), LDA ) CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) CALL CLACGV( I-1, A( I, 1 ), LDA ) CALL CLACGV( I-1, X( I, 1 ), LDX ) CALL CGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE, $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ), $ LDA ) CALL CLACGV( I-1, X( I, 1 ), LDX ) * * Generate reflection P(i) to annihilate A(i,i+1:n) * ALPHA = A( I, I ) CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = ALPHA IF( I.LT.M ) THEN A( I, I ) = ONE * * Compute X(i+1:m,i) * CALL CGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', N-I+1, I-1, ONE, $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO, $ X( 1, I ), 1 ) CALL CGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL CGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL CGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL CLACGV( N-I+1, A( I, I ), LDA ) * * Update A(i+1:m,i) * CALL CLACGV( I-1, Y( I, 1 ), LDY ) CALL CGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) CALL CLACGV( I-1, Y( I, 1 ), LDY ) CALL CGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+2:m,i) * ALPHA = A( I+1, I ) CALL CLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Compute Y(i+1:n,i) * CALL CGEMV( 'Conjugate transpose', M-I, N-I, ONE, $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', M-I, I-1, ONE, $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL CGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', M-I, I, ONE, $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL CGEMV( 'Conjugate transpose', I, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) ELSE CALL CLACGV( N-I+1, A( I, I ), LDA ) END IF 20 CONTINUE END IF RETURN * * End of CLABRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clacgv.f000066400000000000000000000054341522610125300262170ustar00rootroot00000000000000*> \brief \b CLACGV conjugates a complex vector. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLACGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACGV( N, X, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLACGV conjugates a complex vector of length N. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The length of the vector X. N >= 0. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX array, dimension *> (1+(N-1)*abs(INCX)) *> On entry, the vector of length N to be conjugated. *> On exit, X is overwritten with conjg(X). *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The spacing between successive elements of X. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACGV( N, X, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N * .. * .. Array Arguments .. COMPLEX X( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IOFF * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * IF( INCX.EQ.1 ) THEN DO 10 I = 1, N X( I ) = CONJG( X( I ) ) 10 CONTINUE ELSE IOFF = 1 IF( INCX.LT.0 ) $ IOFF = 1 - ( N-1 )*INCX DO 20 I = 1, N X( IOFF ) = CONJG( X( IOFF ) ) IOFF = IOFF + INCX 20 CONTINUE END IF RETURN * * End of CLACGV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clacn2.f000066400000000000000000000174251522610125300261250ustar00rootroot00000000000000*> \brief \b CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLACN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE ) * * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST * .. * .. Array Arguments .. * INTEGER ISAVE( 3 ) * COMPLEX V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLACN2 estimates the 1-norm of a square, complex matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**H * X, if KASE=2, *> where A**H is the conjugate transpose of A, and CLACN2 must be *> re-called with all the other parameters unchanged. *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to CLACN2, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**H * X. *> On the final return from CLACN2, KASE will again be 0. *> \endverbatim *> *> \param[in,out] ISAVE *> \verbatim *> ISAVE is INTEGER array, dimension (3) *> ISAVE is used to save variables between calls to SLACN2 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Originally named CONEST, dated March 16, 1988. *> *> Last modified: April, 1999 *> *> This is a thread safe version of CLACON, which uses the array ISAVE *> in place of a SAVE statement, as follows: *> *> CLACON CLACN2 *> JUMP ISAVE(1) *> J ISAVE(2) *> ITER ISAVE(3) *> \endverbatim * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N REAL EST * .. * .. Array Arguments .. INTEGER ISAVE( 3 ) COMPLEX V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) REAL ONE, TWO PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), $ CONE = ( 1.0E0, 0.0E0 ) ) * .. * .. Local Scalars .. INTEGER I, JLAST REAL ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER ICMAX1 REAL SCSUM1, SLAMCH EXTERNAL ICMAX1, SCSUM1, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, REAL * .. * .. Executable Statements .. * SAFMIN = SLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = CMPLX( ONE / REAL( N ) ) 10 CONTINUE KASE = 1 ISAVE( 1 ) = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) * * ................ ENTRY (ISAVE( 1 ) = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = SCSUM1( N, X, 1 ) * DO 30 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = CMPLX( REAL( X( I ) ) / ABSXI, $ AIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 ISAVE( 1 ) = 2 RETURN * * ................ ENTRY (ISAVE( 1 ) = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE ISAVE( 2 ) = ICMAX1( N, X, 1 ) ISAVE( 3 ) = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( ISAVE( 2 ) ) = CONE KASE = 1 ISAVE( 1 ) = 3 RETURN * * ................ ENTRY (ISAVE( 1 ) = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL CCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = SCSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = CMPLX( REAL( X( I ) ) / ABSXI, $ AIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 ISAVE( 1 ) = 4 RETURN * * ................ ENTRY (ISAVE( 1 ) = 4) * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = ISAVE( 2 ) ISAVE( 2 ) = ICMAX1( N, X, 1 ) IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN ISAVE( 3 ) = ISAVE( 3 ) + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = CMPLX( ALTSGN*( ONE + REAL( I-1 ) / REAL( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 ISAVE( 1 ) = 5 RETURN * * ................ ENTRY (ISAVE( 1 ) = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( SCSUM1( N, X, 1 ) / REAL( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL CCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of CLACN2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clacon.f000066400000000000000000000162471522610125300262230ustar00rootroot00000000000000*> \brief \b CLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLACON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACON( N, V, X, EST, KASE ) * * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST * .. * .. Array Arguments .. * COMPLEX V( N ), X( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLACON estimates the 1-norm of a square, complex matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**H * X, if KASE=2, *> where A**H is the conjugate transpose of A, and CLACON must be *> re-called with all the other parameters unchanged. *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to CLACON, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**H * X. *> On the final return from CLACON, KASE will again be 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> Originally named CONEST, dated March 16, 1988. \n *> Last modified: April, 1999 * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE CLACON( N, V, X, EST, KASE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N REAL EST * .. * .. Array Arguments .. COMPLEX V( N ), X( N ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) REAL ONE, TWO PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), $ CONE = ( 1.0E0, 0.0E0 ) ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP REAL ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER ICMAX1 REAL SCSUM1, SLAMCH EXTERNAL ICMAX1, SCSUM1, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, REAL * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * SAFMIN = SLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = CMPLX( ONE / REAL( N ) ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = SCSUM1( N, X, 1 ) * DO 30 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = CMPLX( REAL( X( I ) ) / ABSXI, $ AIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE J = ICMAX1( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( J ) = CONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL CCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = SCSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = CMPLX( REAL( X( I ) ) / ABSXI, $ AIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = J J = ICMAX1( N, X, 1 ) IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND. $ ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = CMPLX( ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( SCSUM1( N, X, 1 ) / REAL( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL CCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of CLACON * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clacpy.f000066400000000000000000000077441522610125300262410ustar00rootroot00000000000000*> \brief \b CLACPY copies all or part of one two-dimensional array to another. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLACPY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLACPY copies all or part of a two-dimensional matrix A to another *> matrix B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be copied to B. *> = 'U': Upper triangular part *> = 'L': Lower triangular part *> Otherwise: All of the matrix A *> \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] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> The m by n matrix A. If UPLO = 'U', only the upper trapezium *> is accessed; if UPLO = 'L', only the lower trapezium is *> accessed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] B *> \verbatim *> B is COMPLEX array, dimension (LDB,N) *> On exit, B = A in the locations specified by UPLO. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.7.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, LDB, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE * ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF * RETURN * * End of CLACPY * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cladiv.f000066400000000000000000000045411522610125300262200ustar00rootroot00000000000000*> \brief \b CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLADIV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * COMPLEX FUNCTION CLADIV( X, Y ) * * .. Scalar Arguments .. * COMPLEX X, Y * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLADIV := X / Y, where X and Y are complex. The computation of X / Y *> will not overflow on an intermediary step unless the results *> overflows. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is COMPLEX *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is COMPLEX *> The complex scalars X and Y. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== COMPLEX FUNCTION CLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 3.7.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 .. COMPLEX X, Y * .. * * ===================================================================== * * .. Local Scalars .. REAL ZI, ZR * .. * .. External Subroutines .. EXTERNAL SLADIV * .. * .. Intrinsic Functions .. INTRINSIC AIMAG, CMPLX, REAL * .. * .. Executable Statements .. * CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR, $ ZI ) CLADIV = CMPLX( ZR, ZI ) * RETURN * * End of CLADIV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claev2.f000066400000000000000000000105351522610125300261320ustar00rootroot00000000000000*> \brief \b CLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAEV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * .. Scalar Arguments .. * REAL CS1, RT1, RT2 * COMPLEX A, B, C, SN1 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix *> [ A B ] *> [ CONJG(B) C ]. *> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the *> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right *> eigenvector for RT1, giving the decomposition *> *> [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ] *> [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is COMPLEX *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX *> The (1,2) element and the conjugate of the (2,1) element of *> the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is COMPLEX *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is REAL *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is REAL *> The eigenvalue of smaller absolute value. *> \endverbatim *> *> \param[out] CS1 *> \verbatim *> CS1 is REAL *> \endverbatim *> *> \param[out] SN1 *> \verbatim *> SN1 is COMPLEX *> The vector (CS1, SN1) is a unit right eigenvector for RT1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> CS1 and SN1 are accurate to a few ulps barring over/underflow. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL CS1, RT1, RT2 COMPLEX A, B, C, SN1 * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. REAL T COMPLEX W * .. * .. External Subroutines .. EXTERNAL SLAEV2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, REAL * .. * .. Executable Statements .. * IF( ABS( B ).EQ.ZERO ) THEN W = ONE ELSE W = CONJG( B ) / ABS( B ) END IF CALL SLAEV2( REAL( A ), ABS( B ), REAL( C ), RT1, RT2, CS1, T ) SN1 = W*T RETURN * * End of CLAEV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clahqr.f000066400000000000000000000437721522610125300262410ustar00rootroot00000000000000*> \brief \b CLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAHQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAHQR is an auxiliary routine called by CHSEQR to update the *> eigenvalues and Schur decomposition already computed by CHSEQR, by *> dealing with the Hessenberg submatrix in rows and columns ILO to *> IHI. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows and *> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). *> CLAHQR works primarily with the Hessenberg submatrix in rows *> and columns ILO to IHI, but applies transformations to all of *> H if WANTT is .TRUE.. *> 1 <= ILO <= max(1,IHI); IHI <= N. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO is zero and if WANTT is .TRUE., then H *> is upper triangular in rows and columns ILO:IHI. If INFO *> is zero and if WANTT is .FALSE., then the contents of H *> are unspecified on exit. The output state of H in case *> INF is positive is below under the description of INFO. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX array, dimension (N) *> The computed eigenvalues ILO to IHI are stored in the *> corresponding elements of W. If WANTT is .TRUE., the *> eigenvalues are stored in the same order as on the diagonal *> of the Schur form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,N) *> If WANTZ is .TRUE., on entry Z must contain the current *> matrix Z of transformations accumulated by CHSEQR, and on *> exit Z has been updated; transformations are applied only to *> the submatrix Z(ILOZ:IHIZ,ILO:IHI). *> If WANTZ is .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, CLAHQR failed to compute all the *> eigenvalues ILO to IHI in a total of 30 iterations *> per eigenvalue; elements i+1:ihi of W contain *> those eigenvalues which have been successfully *> computed. *> *> If INFO .GT. 0 and WANTT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the *> eigenvalues of the upper Hessenberg matrix *> rows and columns ILO thorugh INFO of the final, *> output value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> (*) (initial value of H)*U = U*(final value of H) *> where U is an orthognal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> (final value of Z) = (initial value of Z)*U *> where U is the orthogonal matrix in (*) *> (regardless of the value of WANTT.) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> \verbatim *> *> 02-96 Based on modifications by *> David Day, Sandia National Laboratory, USA *> *> 12-04 Further modifications by *> Ralph Byers, University of Kansas, USA *> This is a modified version of CLAHQR from LAPACK version 3.0. *> It is (1) more robust against overflow and underflow and *> (2) adopts the more conservative Ahues & Tisseur stopping *> criterion (LAWN 122, 1997). *> \endverbatim *> * ===================================================================== SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * ========================================================= * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL RZERO, RONE, HALF PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0, HALF = 0.5e0 ) REAL DAT1 PARAMETER ( DAT1 = 3.0e0 / 4.0e0 ) * .. * .. Local Scalars .. COMPLEX CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, $ V2, X, Y REAL AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, $ SAFMIN, SMLNUM, SX, T2, TST, ULP INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M, $ NH, NZ * .. * .. Local Arrays .. COMPLEX V( 2 ) * .. * .. External Functions .. COMPLEX CLADIV REAL SLAMCH EXTERNAL CLADIV, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CLARFG, CSCAL, SLABAD * .. * .. Statement Functions .. REAL CABS1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * * ==== clear out the trash ==== DO 10 J = ILO, IHI - 3 H( J+2, J ) = ZERO H( J+3, J ) = ZERO 10 CONTINUE IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * ==== ensure that subdiagonal entries are real ==== IF( WANTT ) THEN JLO = 1 JHI = N ELSE JLO = ILO JHI = IHI END IF DO 20 I = ILO + 1, IHI IF( AIMAG( H( I, I-1 ) ).NE.RZERO ) THEN * ==== The following redundant normalization * . avoids problems with both gradual and * . sudden underflow in ABS(H(I,I-1)) ==== SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) SC = CONJG( SC ) / ABS( SC ) H( I, I-1 ) = ABS( H( I, I-1 ) ) CALL CSCAL( JHI-I+1, SC, H( I, I ), LDH ) CALL CSCAL( MIN( JHI, I+1 )-JLO+1, CONJG( SC ), H( JLO, I ), $ 1 ) IF( WANTZ ) $ CALL CSCAL( IHIZ-ILOZ+1, CONJG( SC ), Z( ILOZ, I ), 1 ) END IF 20 CONTINUE * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITMAX is the total number of QR iterations allowed. * 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 * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 30 CONTINUE IF( I.LT.ILO ) $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO DO 130 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * DO 40 K = I, L + 1, -1 IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) $ GO TO 50 TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) IF( TST.EQ.ZERO ) THEN IF( K-2.GE.ILO ) $ TST = TST + ABS( REAL( H( K-1, K-2 ) ) ) IF( K+1.LE.IHI ) $ TST = TST + ABS( REAL( H( K+1, K ) ) ) END IF * ==== The following is a conservative small subdiagonal * . deflation criterion due to Ahues & Tisseur (LAWN 122, * . 1997). It has better mathematical foundation and * . improves accuracy in some examples. ==== IF( ABS( REAL( H( K, K-1 ) ) ).LE.ULP*TST ) THEN AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) AA = MAX( CABS1( H( K, K ) ), $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) BB = MIN( CABS1( H( K, K ) ), $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) S = AA + AB IF( BA*( AB / S ).LE.MAX( SMLNUM, $ ULP*( BB*( AA / S ) ) ) )GO TO 50 END IF 40 CONTINUE 50 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 ) THEN * * Exceptional shift. * S = DAT1*ABS( REAL( H( L+1, L ) ) ) T = S + H( L, L ) ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * S = DAT1*ABS( REAL( H( I, I-1 ) ) ) T = S + H( I, I ) ELSE * * Wilkinson's shift. * T = H( I, I ) U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) S = CABS1( U ) IF( S.NE.RZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) SX = CABS1( X ) S = MAX( S, CABS1( X ) ) Y = S*SQRT( ( X / S )**2+( U / S )**2 ) IF( SX.GT.RZERO ) THEN IF( REAL( X / SX )*REAL( Y )+AIMAG( X / SX )* $ AIMAG( Y ).LT.RZERO )Y = -Y END IF T = T - U*CLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 60 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T H21 = REAL( H( M+1, M ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 H10 = REAL( H( M, M-1 ) ) IF( ABS( H10 )*ABS( H21 ).LE.ULP* $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) $ GO TO 70 60 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T H21 = REAL( H( L+1, L ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 70 CONTINUE * * Single-shift QR step * DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. * * V(2) is always real before the call to CLARFG, and hence * after the call T2 ( = T1*V(2) ) is also real. * IF( K.GT.M ) $ CALL CCOPY( 2, H( K, K-1 ), 1, V, 1 ) CALL CLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO END IF V2 = V( 2 ) T2 = REAL( T1*V2 ) * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 80 J = K, I2 SUM = CONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 80 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * DO 90 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*CONJG( V2 ) 90 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 100 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*CONJG( V2 ) 100 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN * * If the QR step was started at row M > L because two * consecutive small subdiagonals were found, then extra * scaling must be performed to ensure that H(M,M-1) remains * real. * TEMP = ONE - T1 TEMP = TEMP / ABS( TEMP ) H( M+1, M ) = H( M+1, M )*CONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP DO 110 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL CSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) CALL CSCAL( J-I1, CONJG( TEMP ), H( I1, J ), 1 ) IF( WANTZ ) THEN CALL CSCAL( NZ, CONJG( TEMP ), Z( ILOZ, J ), 1 ) END IF END IF 110 CONTINUE END IF 120 CONTINUE * * Ensure that H(I,I-1) is real. * TEMP = H( I, I-1 ) IF( AIMAG( TEMP ).NE.RZERO ) THEN RTEMP = ABS( TEMP ) H( I, I-1 ) = RTEMP TEMP = TEMP / RTEMP IF( I2.GT.I ) $ CALL CSCAL( I2-I, CONJG( TEMP ), H( I, I+1 ), LDH ) CALL CSCAL( I-I1, TEMP, H( I1, I ), 1 ) IF( WANTZ ) THEN CALL CSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) END IF END IF * 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 140 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * * return to start of the main loop with new value of I. * I = L - 1 GO TO 30 * 150 CONTINUE RETURN * * End of CLAHQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clahr2.f000066400000000000000000000241451522610125300261330ustar00rootroot00000000000000*> \brief \b CLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAHR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) *> matrix A so that elements below the k-th subdiagonal are zero. The *> reduction is performed by an unitary similarity transformation *> Q**H * A * Q. The routine returns the matrices V and T which determine *> Q as a block reflector I - V*T*v**H, and also the matrix Y = A * V * T. *> *> This is an auxiliary routine called by CGEHRD. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The offset for the reduction. Elements below the k-th *> subdiagonal in the first NB columns are reduced to zero. *> K < N. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N-K+1) *> On entry, the n-by-(n-k+1) general matrix A. *> On exit, the elements on and above the k-th subdiagonal in *> the first NB columns are overwritten with the corresponding *> elements of the reduced matrix; the elements below the k-th *> subdiagonal, with the array TAU, represent the matrix Q as a *> product of elementary reflectors. The other columns of A are *> unchanged. 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] TAU *> \verbatim *> TAU is COMPLEX array, dimension (NB) *> The scalar factors of the elementary reflectors. See Further *> Details. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX array, dimension (LDT,NB) *> The upper triangular matrix T. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is COMPLEX array, dimension (LDY,NB) *> The n-by-nb matrix Y. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of nb elementary reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in *> A(i+k+1:n,i), and tau in TAU(i). *> *> The elements of the vectors v together form the (n-k+1)-by-nb matrix *> V which is needed, with T and Y, to apply the transformation to the *> unreduced part of the matrix, using an update of the form: *> A := (I - V*T*V**H) * (A - Y*V**H). *> *> The contents of A on exit are illustrated by the following example *> with n = 7, k = 3 and nb = 2: *> *> ( a a a a a ) *> ( a a a a a ) *> ( a a a a a ) *> ( h h a a a ) *> ( v1 h a a a ) *> ( v1 v2 a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This subroutine is a slight modification of LAPACK-3.0's DLAHRD *> incorporating improvements proposed by Quintana-Orti and Van de *> Gejin. Note that the entries of A(1:K,2:NB) differ from those *> returned by the original LAPACK-3.0's DLAHRD routine. (This *> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) *> \endverbatim * *> \par References: * ================ *> *> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the *> performance of reduction to Hessenberg form," ACM Transactions on *> Mathematical Software, 32(2):180-194, June 2006. *> * ===================================================================== SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.7.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 K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX EI * .. * .. External Subroutines .. EXTERNAL CAXPY, CCOPY, CGEMM, CGEMV, CLACPY, $ CLARFG, CSCAL, CTRMM, CTRMV, CLACGV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(K+1:N,I) * * Update I-th column of A - Y * V**H * 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 ) * * Apply I - V * T**H * V**H to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1**H * b1 * CALL CCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) 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, $ 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', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * 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', $ '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 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(I) to annihilate * A(K+I+1:N,I) * CALL CLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(K+1:N,I) * 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, $ 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, $ 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 ) * * Compute T(1:I,I) * CALL CSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL CTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * * Compute Y(1:K,1:NB) * CALL CLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) 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, $ 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', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * RETURN * * End of CLAHR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claic1.f000066400000000000000000000242221522610125300261100ustar00rootroot00000000000000*> \brief \b CLAIC1 applies one step of incremental condition estimation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAIC1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * .. Scalar Arguments .. * INTEGER J, JOB * REAL SEST, SESTPR * COMPLEX C, GAMMA, S * .. * .. Array Arguments .. * COMPLEX W( J ), X( J ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAIC1 applies one step of incremental condition estimation in *> its simplest version: *> *> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j *> lower triangular matrix L, such that *> twonorm(L*x) = sest *> Then CLAIC1 computes sestpr, s, c such that *> the vector *> [ s*x ] *> xhat = [ c ] *> is an approximate singular vector of *> [ L 0 ] *> Lhat = [ w**H gamma ] *> in the sense that *> twonorm(Lhat*xhat) = sestpr. *> *> Depending on JOB, an estimate for the largest or smallest singular *> value is computed. *> *> Note that [s c]**H and sestpr**2 is an eigenpair of the system *> *> diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] *> [ conjg(gamma) ] *> *> where alpha = x**H*w. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is INTEGER *> = 1: an estimate for the largest singular value is computed. *> = 2: an estimate for the smallest singular value is computed. *> \endverbatim *> *> \param[in] J *> \verbatim *> J is INTEGER *> Length of X and W *> \endverbatim *> *> \param[in] X *> \verbatim *> X is COMPLEX array, dimension (J) *> The j-vector x. *> \endverbatim *> *> \param[in] SEST *> \verbatim *> SEST is REAL *> Estimated singular value of j by j matrix L *> \endverbatim *> *> \param[in] W *> \verbatim *> W is COMPLEX array, dimension (J) *> The j-vector w. *> \endverbatim *> *> \param[in] GAMMA *> \verbatim *> GAMMA is COMPLEX *> The diagonal element gamma. *> \endverbatim *> *> \param[out] SESTPR *> \verbatim *> SESTPR is REAL *> Estimated singular value of (j+1) by (j+1) matrix Lhat. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is COMPLEX *> Sine needed in forming xhat. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is COMPLEX *> Cosine needed in forming xhat. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * -- LAPACK auxiliary routine (version 3.7.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 J, JOB REAL SEST, SESTPR COMPLEX C, GAMMA, S * .. * .. Array Arguments .. COMPLEX W( J ), X( J ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 ) REAL HALF, FOUR PARAMETER ( HALF = 0.5E0, FOUR = 4.0E0 ) * .. * .. Local Scalars .. REAL ABSALP, ABSEST, ABSGAM, B, EPS, NORMA, S1, S2, $ SCL, T, TEST, TMP, ZETA1, ZETA2 COMPLEX ALPHA, COSINE, SINE * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, SQRT * .. * .. External Functions .. REAL SLAMCH COMPLEX CDOTC EXTERNAL SLAMCH, CDOTC * .. * .. Executable Statements .. * EPS = SLAMCH( 'Epsilon' ) ALPHA = CDOTC( J, X, 1, W, 1 ) * ABSALP = ABS( ALPHA ) ABSGAM = ABS( GAMMA ) ABSEST = ABS( SEST ) * IF( JOB.EQ.1 ) THEN * * Estimating largest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN S1 = MAX( ABSGAM, ABSALP ) IF( S1.EQ.ZERO ) THEN S = ZERO C = ONE SESTPR = ZERO ELSE S = ALPHA / S1 C = GAMMA / S1 TMP = SQRT( S*CONJG( S )+C*CONJG( C ) ) S = S / TMP C = C / TMP SESTPR = S1*TMP END IF RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ONE C = ZERO TMP = MAX( ABSEST, ABSALP ) S1 = ABSEST / TMP S2 = ABSALP / TMP SESTPR = TMP*SQRT( S1*S1+S2*S2 ) RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ONE C = ZERO SESTPR = S2 ELSE S = ZERO C = ONE SESTPR = S1 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 SCL = SQRT( ONE+TMP*TMP ) SESTPR = S2*SCL S = ( ALPHA / S2 ) / SCL C = ( GAMMA / S2 ) / SCL ELSE TMP = S2 / S1 SCL = SQRT( ONE+TMP*TMP ) SESTPR = S1*SCL S = ( ALPHA / S1 ) / SCL C = ( GAMMA / S1 ) / SCL END IF RETURN ELSE * * normal case * ZETA1 = ABSALP / ABSEST ZETA2 = ABSGAM / ABSEST * B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF C = ZETA1*ZETA1 IF( B.GT.ZERO ) THEN T = C / ( B+SQRT( B*B+C ) ) ELSE T = SQRT( B*B+C ) - B END IF * SINE = -( ALPHA / ABSEST ) / T COSINE = -( GAMMA / ABSEST ) / ( ONE+T ) TMP = SQRT( SINE*CONJG( SINE )+COSINE*CONJG( COSINE ) ) S = SINE / TMP C = COSINE / TMP SESTPR = SQRT( T+ONE )*ABSEST RETURN END IF * ELSE IF( JOB.EQ.2 ) THEN * * Estimating smallest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN SESTPR = ZERO IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN SINE = ONE COSINE = ZERO ELSE SINE = -CONJG( GAMMA ) COSINE = CONJG( ALPHA ) END IF S1 = MAX( ABS( SINE ), ABS( COSINE ) ) S = SINE / S1 C = COSINE / S1 TMP = SQRT( S*CONJG( S )+C*CONJG( C ) ) S = S / TMP C = C / TMP RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ZERO C = ONE SESTPR = ABSGAM RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ZERO C = ONE SESTPR = S1 ELSE S = ONE C = ZERO SESTPR = S2 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 SCL = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST*( TMP / SCL ) S = -( CONJG( GAMMA ) / S2 ) / SCL C = ( CONJG( ALPHA ) / S2 ) / SCL ELSE TMP = S2 / S1 SCL = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST / SCL S = -( CONJG( GAMMA ) / S1 ) / SCL C = ( CONJG( ALPHA ) / S1 ) / SCL END IF RETURN ELSE * * normal case * ZETA1 = ABSALP / ABSEST ZETA2 = ABSGAM / ABSEST * NORMA = MAX( ONE+ZETA1*ZETA1+ZETA1*ZETA2, $ ZETA1*ZETA2+ZETA2*ZETA2 ) * * See if root is closer to zero or to ONE * TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) IF( TEST.GE.ZERO ) THEN * * root is close to zero, compute directly * B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF C = ZETA2*ZETA2 T = C / ( B+SQRT( ABS( B*B-C ) ) ) SINE = ( ALPHA / ABSEST ) / ( ONE-T ) COSINE = -( GAMMA / ABSEST ) / T SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST ELSE * * root is closer to ONE, shift by that amount * B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF C = ZETA1*ZETA1 IF( B.GE.ZERO ) THEN T = -C / ( B+SQRT( B*B+C ) ) ELSE T = B - SQRT( B*B+C ) END IF SINE = -( ALPHA / ABSEST ) / T COSINE = -( GAMMA / ABSEST ) / ( ONE+T ) SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST END IF TMP = SQRT( SINE*CONJG( SINE )+COSINE*CONJG( COSINE ) ) S = SINE / TMP C = COSINE / TMP RETURN * END IF END IF RETURN * * End of CLAIC1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clamtsqr.f000066400000000000000000000270001522610125300265770ustar00rootroot00000000000000*> \brief \b CLAMTSQR * * 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**H * C C * Q**H *> 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Conjugate Transpose, apply Q**H. *> \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] 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**H*C or C*Q**H 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clanhs.f000066400000000000000000000132611522610125300262250ustar00rootroot00000000000000*> \brief \b CLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLANHS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N * .. * .. Array Arguments .. * REAL WORK( * ) * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLANHS returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> Hessenberg matrix A. *> \endverbatim *> *> \return CLANHS *> \verbatim *> *> CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in CLANHS as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, CLANHS is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> The n by n upper Hessenberg matrix A; the part of A below the *> first sub-diagonal is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 NORM INTEGER LDA, N * .. * .. Array Arguments .. REAL WORK( * ) COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL CLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * CLANHS = VALUE RETURN * * End of CLANHS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqp2.f000066400000000000000000000171351522610125300261430ustar00rootroot00000000000000*> \brief \b CLAQP2 computes a QR factorization with column pivoting of the matrix block. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQP2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) * * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL VN1( * ), VN2( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAQP2 computes a QR factorization with column pivoting of *> the block A(OFFSET+1:M,1:N). *> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted *> but no factorized. OFFSET >= 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 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is REAL array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is REAL array, dimension (N) *> The vector with the exact column norms. *> \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 complexOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, M, N, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL VN1( * ), VN2( * ) COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE COMPLEX CONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT REAL TEMP, TEMP2, TOL3Z COMPLEX AII * .. * .. External Subroutines .. EXTERNAL CLARF, CLARFG, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SCNRM2, SLAMCH EXTERNAL ISAMAX, SCNRM2, SLAMCH * .. * .. Executable Statements .. * MN = MIN( M-OFFSET, N ) TOL3Z = SQRT(SLAMCH('Epsilon')) * * Compute factorization. * DO 20 I = 1, MN * OFFPI = OFFSET + I * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 ) + ISAMAX( N-I+1, VN1( I ), 1 ) * IF( PVT.NE.I ) THEN CALL CSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP VN1( PVT ) = VN1( I ) VN2( PVT ) = VN2( I ) END IF * * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN CALL CLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, $ TAU( I ) ) ELSE CALL CLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i)**H to A(offset+i:m,i+1:n) from the left. * AII = A( OFFPI, I ) A( OFFPI, I ) = CONE CALL CLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, $ WORK( 1 ) ) A( OFFPI, I ) = AII END IF * * Update partial column norms. * DO 10 J = I + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( OFFPI.LT.M ) THEN VN1( J ) = SCNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) VN2( J ) = VN1( J ) ELSE VN1( J ) = ZERO VN2( J ) = ZERO END IF ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 10 CONTINUE * 20 CONTINUE * RETURN * * End of CLAQP2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqps.f000066400000000000000000000254011522610125300262370ustar00rootroot00000000000000*> \brief \b CLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQPS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL VN1( * ), VN2( * ) * COMPLEX A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAQPS computes a step of QR factorization with column pivoting *> of a complex M-by-N matrix A by using Blas-3. It tries to factorize *> NB columns from A starting from the row OFFSET+1, and updates all *> of the matrix with Blas-3 xGEMM. *> *> In some cases, due to catastrophic cancellations, it cannot *> factorize NB columns. Hence, the actual number of factorized *> columns is returned in KB. *> *> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of A that have been factorized in *> previous steps. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to factorize. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER *> The number of columns actually factorized. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, block A(OFFSET+1:M,1:KB) is the triangular *> factor obtained and block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. *> The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has *> been updated. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> JPVT(I) = K <==> Column K of the full matrix A has been *> permuted into position I in AP. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX array, dimension (KB) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is REAL array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is REAL array, dimension (N) *> The vector with the exact column norms. *> \endverbatim *> *> \param[in,out] AUXV *> \verbatim *> AUXV is COMPLEX array, dimension (NB) *> Auxiliar vector. *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is COMPLEX array, dimension (LDF,NB) *> Matrix F**H = L * Y**H * A. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * * -- LAPACK auxiliary routine (version 3.7.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 KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL VN1( * ), VN2( * ) COMPLEX A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE COMPLEX CZERO, CONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK REAL TEMP, TEMP2, TOL3Z COMPLEX AKK * .. * .. External Subroutines .. EXTERNAL CGEMM, CGEMV, CLARFG, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, MIN, NINT, REAL, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SCNRM2, SLAMCH EXTERNAL ISAMAX, SCNRM2, SLAMCH * .. * .. Executable Statements .. * LASTRK = MIN( M, N+OFFSET ) LSTICC = 0 K = 0 TOL3Z = SQRT(SLAMCH('Epsilon')) * * Beginning of while loop. * 10 CONTINUE IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN K = K + 1 RK = OFFSET + K * * Determine ith pivot column and swap if necessary * PVT = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 ) IF( PVT.NE.K ) THEN CALL CSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) CALL CSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( K ) JPVT( K ) = ITEMP VN1( PVT ) = VN1( K ) VN2( PVT ) = VN2( K ) END IF * * Apply previous Householder reflectors to column K: * A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**H. * IF( K.GT.1 ) THEN DO 20 J = 1, K - 1 F( K, J ) = CONJG( F( K, J ) ) 20 CONTINUE CALL CGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ), $ LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 ) DO 30 J = 1, K - 1 F( K, J ) = CONJG( F( K, J ) ) 30 CONTINUE END IF * * Generate elementary reflector H(k). * IF( RK.LT.M ) THEN CALL CLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) ELSE CALL CLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) END IF * AKK = A( RK, K ) A( RK, K ) = CONE * * Compute Kth column of F: * * Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). * IF( K.LT.N ) THEN CALL CGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ), $ A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO, $ F( K+1, K ), 1 ) END IF * * Padding F(1:K,K) with zeros. * DO 40 J = 1, K F( J, K ) = CZERO 40 CONTINUE * * Incremental updating of F: * F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**H * *A(RK:M,K). * IF( K.GT.1 ) THEN CALL CGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ), $ A( RK, 1 ), LDA, A( RK, K ), 1, CZERO, $ AUXV( 1 ), 1 ) * CALL CGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF, $ AUXV( 1 ), 1, CONE, F( 1, K ), 1 ) END IF * * Update the current row of A: * A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**H. * IF( K.LT.N ) THEN CALL CGEMM( 'No transpose', 'Conjugate transpose', 1, N-K, $ K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF, $ CONE, A( RK, K+1 ), LDA ) END IF * * Update partial column norms. * IF( RK.LT.LASTRK ) THEN DO 50 J = K + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN VN2( J ) = REAL( LSTICC ) LSTICC = J ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 50 CONTINUE END IF * A( RK, K ) = AKK * * End of while loop. * GO TO 10 END IF KB = K RK = OFFSET + KB * * Apply the block reflector to the rest of the matrix: * A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - * A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**H. * IF( KB.LT.MIN( N, M-OFFSET ) ) THEN CALL CGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB, $ KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, $ CONE, A( RK+1, KB+1 ), LDA ) END IF * * Recomputation of difficult columns. * 60 CONTINUE IF( LSTICC.GT.0 ) THEN 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 * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP GO TO 60 END IF * RETURN * * End of CLAQPS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqr0.f000066400000000000000000000607421522610125300261450ustar00rootroot00000000000000*> \brief \b CLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQR0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAQR0 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**H, where T is an upper triangular matrix (the *> Schur form), and Z is the unitary matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to CGEBAL, and then passed to CGEHRD when the *> matrix output by CGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H *> contains the upper triangular matrix T from the Schur *> decomposition (the Schur form). If INFO = 0 and WANT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX array, dimension (N) *> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored *> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are *> stored in the same order as on the diagonal of the Schur *> form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then CLAQR0 does a workspace query. *> In this case, CLAQR0 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, CLAQR0 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a unitary matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the unitary matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . CLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constant WILK1 is used to form the exceptional * . shifts. ==== REAL WILK1 PARAMETER ( WILK1 = 0.75e0 ) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL TWO PARAMETER ( TWO = 2.0e0 ) * .. * .. Local Scalars .. COMPLEX AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 REAL S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. COMPLEX ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL CLACPY, CLAHQR, CLAQR3, CLAQR4, CLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, INT, MAX, MIN, MOD, REAL, $ SQRT * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use CLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to CLAQR3 ==== * CALL CLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, $ LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(CLAQR5, CLAQR3) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = CMPLX( LWKOPT, 0 ) RETURN END IF * * ==== CLAHQR/CLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 70 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 80 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, $ LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if CLAQR3 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . CLAQR3 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, KS + 1, -2 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) W( I-1 ) = W( I ) 30 CONTINUE ELSE * * ==== Got NS/2 or fewer shifts? Use CLAQR4 or * . CLAHQR on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL CLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) IF( NS.GT.NMIN ) THEN CALL CLAQR4( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, $ ZDUM, 1, WORK, LWORK, INF ) ELSE CALL CLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, $ ZDUM, 1, INF ) END IF KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. Scale to avoid * . overflows, underflows and subnormals. * . (The scale factor S can not be zero, * . because H(KBOT,KBOT-1) is nonzero.) ==== * IF( KS.GE.KBOT ) THEN S = CABS1( H( KBOT-1, KBOT-1 ) ) + $ CABS1( H( KBOT, KBOT-1 ) ) + $ CABS1( H( KBOT-1, KBOT ) ) + $ CABS1( H( KBOT, KBOT ) ) AA = H( KBOT-1, KBOT-1 ) / S CC = H( KBOT, KBOT-1 ) / S BB = H( KBOT-1, KBOT ) / S DD = H( KBOT, KBOT ) / S TR2 = ( AA+DD ) / TWO DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC RTDISC = SQRT( -DET ) W( KBOT-1 ) = ( TR2+RTDISC )*S W( KBOT ) = ( TR2-RTDISC )*S * KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) $ THEN SORTED = .false. SWAP = W( I ) W( I ) = W( I+1 ) W( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF END IF * * ==== If there are only two shifts, then use * . only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN W( KBOT-1 ) = W( KBOT ) ELSE W( KBOT ) = W( KBOT-1 ) END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, $ NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 70 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 80 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = CMPLX( LWKOPT, 0 ) * * ==== End of CLAQR0 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqr1.f000066400000000000000000000113471522610125300261430ustar00rootroot00000000000000*> \brief \b CLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQR1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V ) * * .. Scalar Arguments .. * COMPLEX S1, S2 * INTEGER LDH, N * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), V( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a *> scalar multiple of the first column of the product *> *> (*) K = (H - s1*I)*(H - s2*I) *> *> scaling to avoid overflows and most underflows. *> *> This is useful for starting double implicit shift bulges *> in the QR algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is integer *> Order of the matrix H. N must be either 2 or 3. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is COMPLEX array of dimension (LDH,N) *> The 2-by-2 or 3-by-3 matrix H in (*). *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> The leading dimension of H as declared in *> the calling procedure. LDH.GE.N *> \endverbatim *> *> \param[in] S1 *> \verbatim *> S1 is COMPLEX *> \endverbatim *> *> \param[in] S2 *> \verbatim *> S2 is COMPLEX *> *> S1 and S2 are the shifts defining K in (*) above. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX array of dimension N *> A scalar multiple of the first column of the *> matrix K in (*). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V ) * * -- LAPACK auxiliary routine (version 3.7.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 .. COMPLEX S1, S2 INTEGER LDH, N * .. * .. Array Arguments .. COMPLEX H( LDH, * ), V( * ) * .. * * ================================================================ * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0e0 ) * .. * .. Local Scalars .. COMPLEX CDUM, H21S, H31S REAL S * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. IF( N.EQ.2 ) THEN S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) IF( S.EQ.RZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO ELSE H21S = H( 2, 1 ) / S V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* $ ( ( H( 1, 1 )-S2 ) / S ) V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) END IF ELSE S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + $ CABS1( H( 3, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO V( 3 ) = ZERO ELSE H21S = H( 2, 1 ) / S H31S = H( 3, 1 ) / S V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) END IF END IF END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqr2.f000066400000000000000000000422551522610125300261460ustar00rootroot00000000000000*> \brief \b CLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAQR2 is identical to CLAQR3 except that it avoids *> recursion by calling CLAHQR instead of CLAQR4. *> *> Aggressive early deflation: *> *> This subroutine accepts as input an upper Hessenberg matrix *> H and performs an unitary similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an unitary similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the unitary matrix Z is updated so *> so that the unitary Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the unitary matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by a unitary *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SH *> \verbatim *> SH is COMPLEX array, dimension KBOT *> On output, approximate eigenvalues that may *> be used for shifts are stored in SH(KBOT-ND-NS+1) *> through SR(KBOT-ND). Converged eigenvalues are *> stored in SH(KBOT-ND+1) through SH(KBOT). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is COMPLEX array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension LWORK. *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; CLAQR2 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.7.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 IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL RZERO, RONE PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. COMPLEX BETA, CDUM, S, TAU REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLARF, $ CLARFG, CLASET, CTREXC, CUNMHR, SLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to CGEHRD ==== * CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to CUNMHR ==== * CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = JW + MAX( LWK1, LWK2 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = CMPLX( LWKOPT, 0 ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SH( KWTOP ) = H( KWTOP, KWTOP ) NS = 1 ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, INFQR ) * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 DO 10 KNT = INFQR + 1, JW * * ==== Small spike tip deflation test ==== * FOO = CABS1( T( NS, NS ) ) IF( FOO.EQ.RZERO ) $ FOO = CABS1( S ) IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) $ THEN * * ==== One more converged eigenvalue ==== * NS = NS - 1 ELSE * * ==== One undeflatable eigenvalue. Move it up out of the * . way. (CTREXC can not fail in this case.) ==== * IFST = NS CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) ILST = ILST + 1 END IF 10 CONTINUE * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting the diagonal of T improves accuracy for * . graded matrices. ==== * DO 30 I = INFQR + 1, NS IFST = I DO 20 J = I + 1, NS IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) $ IFST = J 20 CONTINUE ILST = I IF( IFST.NE.ILST ) $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 30 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * DO 40 I = INFQR + 1, JW SH( KWTOP+I-1 ) = T( I, I ) 40 CONTINUE * * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL CCOPY( NS, V, LDV, WORK, 1 ) DO 50 I = 1, NS WORK( I ) = CONJG( WORK( I ) ) 50 CONTINUE BETA = WORK( 1 ) CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, $ WORK( JW+1 ) ) CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*CONJG( V( 1, 1 ) ) CALL CLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL CCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 60 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 70 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL CGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL CLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 70 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 80 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = CMPLX( LWKOPT, 0 ) * * ==== End of CLAQR2 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqr3.f000066400000000000000000000431131522610125300261410ustar00rootroot00000000000000*> \brief \b CLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQR3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Aggressive early deflation: *> *> CLAQR3 accepts as input an upper Hessenberg matrix *> H and performs an unitary similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an unitary similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the unitary matrix Z is updated so *> so that the unitary Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the unitary matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by a unitary *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SH *> \verbatim *> SH is COMPLEX array, dimension KBOT *> On output, approximate eigenvalues that may *> be used for shifts are stored in SH(KBOT-ND-NS+1) *> through SR(KBOT-ND). Converged eigenvalues are *> stored in SH(KBOT-ND+1) through SH(KBOT). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is COMPLEX array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension LWORK. *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; CLAQR3 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL RZERO, RONE PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. COMPLEX BETA, CDUM, S, TAU REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, $ LWKOPT, NMIN * .. * .. External Functions .. REAL SLAMCH INTEGER ILAENV EXTERNAL SLAMCH, ILAENV * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4, $ CLARF, CLARFG, CLASET, CTREXC, CUNMHR, SLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to CGEHRD ==== * CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to CUNMHR ==== * CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to CLAQR4 ==== * CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, $ LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = CMPLX( LWKOPT, 0 ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SH( KWTOP ) = H( KWTOP, KWTOP ) NS = 1 ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'CLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, WORK, LWORK, INFQR ) ELSE CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, INFQR ) END IF * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 DO 10 KNT = INFQR + 1, JW * * ==== Small spike tip deflation test ==== * FOO = CABS1( T( NS, NS ) ) IF( FOO.EQ.RZERO ) $ FOO = CABS1( S ) IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) $ THEN * * ==== One more converged eigenvalue ==== * NS = NS - 1 ELSE * * ==== One undeflatable eigenvalue. Move it up out of the * . way. (CTREXC can not fail in this case.) ==== * IFST = NS CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) ILST = ILST + 1 END IF 10 CONTINUE * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting the diagonal of T improves accuracy for * . graded matrices. ==== * DO 30 I = INFQR + 1, NS IFST = I DO 20 J = I + 1, NS IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) $ IFST = J 20 CONTINUE ILST = I IF( IFST.NE.ILST ) $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 30 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * DO 40 I = INFQR + 1, JW SH( KWTOP+I-1 ) = T( I, I ) 40 CONTINUE * * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL CCOPY( NS, V, LDV, WORK, 1 ) DO 50 I = 1, NS WORK( I ) = CONJG( WORK( I ) ) 50 CONTINUE BETA = WORK( 1 ) CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, $ WORK( JW+1 ) ) CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*CONJG( V( 1, 1 ) ) CALL CLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL CCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 60 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 70 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL CGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL CLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 70 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 80 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = CMPLX( LWKOPT, 0 ) * * ==== End of CLAQR3 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqr4.f000066400000000000000000000610261522610125300261450ustar00rootroot00000000000000*> \brief \b CLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQR4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAQR4 implements one level of recursion for CLAQR0. *> It is a complete implementation of the small bulge multi-shift *> QR algorithm. It may be called by CLAQR0 and, for large enough *> deflation window size, it may be called by CLAQR3. This *> subroutine is identical to CLAQR0 except that it calls CLAQR2 *> instead of CLAQR3. *> *> CLAQR4 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**H, where T is an upper triangular matrix (the *> Schur form), and Z is the unitary matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to CGEBAL, and then passed to CGEHRD when the *> matrix output by CGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H *> contains the upper triangular matrix T from the Schur *> decomposition (the Schur form). If INFO = 0 and WANT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX array, dimension (N) *> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored *> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are *> stored in the same order as on the diagonal of the Schur *> form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then CLAQR4 does a workspace query. *> In this case, CLAQR4 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, CLAQR4 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a unitary matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the unitary matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * * ================================================================ * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . CLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constant WILK1 is used to form the exceptional * . shifts. ==== REAL WILK1 PARAMETER ( WILK1 = 0.75e0 ) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL TWO PARAMETER ( TWO = 2.0e0 ) * .. * .. Local Scalars .. COMPLEX AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 REAL S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. COMPLEX ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL CLACPY, CLAHQR, CLAQR2, CLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, INT, MAX, MIN, MOD, REAL, $ SQRT * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use CLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to CLAQR2 ==== * CALL CLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, $ LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(CLAQR5, CLAQR2) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = CMPLX( LWKOPT, 0 ) RETURN END IF * * ==== CLAHQR/CLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 70 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 80 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, $ LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if CLAQR2 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . CLAQR2 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, KS + 1, -2 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) W( I-1 ) = W( I ) 30 CONTINUE ELSE * * ==== Got NS/2 or fewer shifts? Use CLAHQR * . on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL CLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) CALL CLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, $ 1, INF ) KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. Scale to avoid * . overflows, underflows and subnormals. * . (The scale factor S can not be zero, * . because H(KBOT,KBOT-1) is nonzero.) ==== * IF( KS.GE.KBOT ) THEN S = CABS1( H( KBOT-1, KBOT-1 ) ) + $ CABS1( H( KBOT, KBOT-1 ) ) + $ CABS1( H( KBOT-1, KBOT ) ) + $ CABS1( H( KBOT, KBOT ) ) AA = H( KBOT-1, KBOT-1 ) / S CC = H( KBOT, KBOT-1 ) / S BB = H( KBOT-1, KBOT ) / S DD = H( KBOT, KBOT ) / S TR2 = ( AA+DD ) / TWO DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC RTDISC = SQRT( -DET ) W( KBOT-1 ) = ( TR2+RTDISC )*S W( KBOT ) = ( TR2-RTDISC )*S * KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) $ THEN SORTED = .false. SWAP = W( I ) W( I ) = W( I+1 ) W( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF END IF * * ==== If there are only two shifts, then use * . only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN W( KBOT-1 ) = W( KBOT ) ELSE W( KBOT ) = W( KBOT-1 ) END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, $ NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 70 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 80 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = CMPLX( LWKOPT, 0 ) * * ==== End of CLAQR4 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claqr5.f000066400000000000000000001015171522610125300261460ustar00rootroot00000000000000*> \brief \b CLAQR5 performs a single small-bulge multi-shift QR sweep. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLAQR5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * COMPLEX H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), * $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLAQR5 called by CLAQR0 performs a *> single small-bulge multi-shift QR sweep. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is logical scalar *> WANTT = .true. if the triangular Schur factor *> is being computed. WANTT is set to .false. otherwise. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is logical scalar *> WANTZ = .true. if the unitary Schur factor is being *> computed. WANTZ is set to .false. otherwise. *> \endverbatim *> *> \param[in] KACC22 *> \verbatim *> KACC22 is integer with value 0, 1, or 2. *> Specifies the computation mode of far-from-diagonal *> orthogonal updates. *> = 0: CLAQR5 does not accumulate reflections and does not *> use matrix-matrix multiply to update far-from-diagonal *> matrix entries. *> = 1: CLAQR5 accumulates reflections and uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries. *> = 2: CLAQR5 accumulates reflections, uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries, *> and takes advantage of 2-by-2 block structure during *> matrix multiplies. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is integer scalar *> N is the order of the Hessenberg matrix H upon which this *> subroutine operates. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is integer scalar *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is integer scalar *> These are the first and last rows and columns of an *> isolated diagonal block upon which the QR sweep is to be *> applied. It is assumed without a check that *> either KTOP = 1 or H(KTOP,KTOP-1) = 0 *> and *> either KBOT = N or H(KBOT+1,KBOT) = 0. *> \endverbatim *> *> \param[in] NSHFTS *> \verbatim *> NSHFTS is integer scalar *> NSHFTS gives the number of simultaneous shifts. NSHFTS *> must be positive and even. *> \endverbatim *> *> \param[in,out] S *> \verbatim *> S is COMPLEX array of size (NSHFTS) *> S contains the shifts of origin that define the multi- *> shift QR sweep. On output S may be reordered. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX array of size (LDH,N) *> On input H contains a Hessenberg matrix. On output a *> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied *> to the isolated diagonal block in rows and columns KTOP *> through KBOT. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer scalar *> LDH is the leading dimension of H just as declared in the *> calling procedure. LDH.GE.MAX(1,N). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array of size (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep unitary *> similarity transformation is accumulated into *> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer scalar *> LDA is the leading dimension of Z just as declared in *> the calling procedure. LDZ.GE.N. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX array of size (LDV,NSHFTS/2) *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> LDV is the leading dimension of V as declared in the *> calling procedure. LDV.GE.3. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is COMPLEX array of size *> (LDU,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is integer scalar *> LDU is the leading dimension of U just as declared in the *> in the calling subroutine. LDU.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> NH is the number of columns in array WH available for *> workspace. NH.GE.1. *> \endverbatim *> *> \param[out] WH *> \verbatim *> WH is COMPLEX array of size (LDWH,NH) *> \endverbatim *> *> \param[in] LDWH *> \verbatim *> LDWH is integer scalar *> Leading dimension of WH just as declared in the *> calling procedure. LDWH.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer scalar *> NV is the number of rows in WV agailable for workspace. *> NV.GE.1. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is COMPLEX array of size *> (LDWV,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer scalar *> LDWV is the leading dimension of WV as declared in the *> in the calling subroutine. LDWV.GE.NV. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), $ ONE = ( 1.0e0, 0.0e0 ) ) REAL RZERO, RONE PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. COMPLEX ALPHA, BETA, CDUM, REFSUM REAL H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, $ SMLNUM, TST1, TST2, ULP INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, $ NS, NU LOGICAL ACCUM, BLK22, BMP22 * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. * INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL * .. * .. Local Arrays .. COMPLEX VT( 3 ) * .. * .. External Subroutines .. EXTERNAL CGEMM, CLACPY, CLAQR1, CLARFG, CLASET, CTRMM, $ SLABAD * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== If there are no shifts, then there is nothing to do. ==== * IF( NSHFTS.LT.2 ) $ RETURN * * ==== If the active block is empty or 1-by-1, then there * . is nothing to do. ==== * IF( KTOP.GE.KBOT ) $ RETURN * * ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) * * ==== Machine constants for deflation ==== * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * * ==== Use accumulated reflections to update far-from-diagonal * . entries ? ==== * ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) * * ==== If so, exploit the 2-by-2 block structure? ==== * BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) * * ==== clear trash ==== * IF( KTOP+2.LE.KBOT ) $ H( KTOP+2, KTOP ) = ZERO * * ==== NBMPS = number of 2-shift bulges in the chain ==== * NBMPS = NS / 2 * * ==== KDU = width of slab ==== * KDU = 6*NBMPS - 3 * * ==== Create and chase chains of NBMPS bulges ==== * DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 NDCOL = INCOL + KDU IF( ACCUM ) $ CALL CLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) * * ==== Near-the-diagonal bulge chase. The following loop * . performs the near-the-diagonal part of a small bulge * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal * . chunk extends from column INCOL to column NDCOL * . (including both column INCOL and column NDCOL). The * . following loop chases a 3*NBMPS column long chain of * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL * . may be less than KTOP and and NDCOL may be greater than * . KBOT indicating phantom columns from which to chase * . bulges before they are actually introduced or to which * . to chase bulges beyond column KBOT.) ==== * DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) * * ==== Bulges number MTOP to MBOT are active double implicit * . shift bulges. There may or may not also be small * . 2-by-2 bulge, if there is room. The inactive bulges * . (if any) must wait until the active bulges have moved * . down the diagonal to make room. The phantom matrix * . paradigm described above helps keep track. ==== * MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) M22 = MBOT + 1 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. $ ( KBOT-2 ) * * ==== Generate reflections to chase the chain right * . one column. (The minimum value of K is KTOP-1.) ==== * DO 10 M = MTOP, MBOT K = KRCOL + 3*( M-1 ) IF( K.EQ.KTOP-1 ) THEN CALL CLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), $ S( 2*M ), V( 1, M ) ) ALPHA = V( 1, M ) CALL CLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) ELSE BETA = H( K+1, K ) V( 2, M ) = H( K+2, K ) V( 3, M ) = H( K+3, K ) CALL CLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant * . deflation or destructive underflow. In the * . underflow case, try the two-small-subdiagonals * . trick to try to reinflate the bulge. ==== * IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Atypical case: collapsed. Attempt to * . reintroduce ignoring H(K+1,K) and H(K+2,K). * . If the fill resulting from the new * . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL CLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), $ S( 2*M ), VT ) ALPHA = VT( 1 ) CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = CONJG( VT( 1 ) )* $ ( H( K+1, K )+CONJG( VT( 2 ) )* $ H( K+2, K ) ) * IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* $ ( CABS1( H( K, K ) )+CABS1( H( K+1, $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would * . create non-negligible fill. Use * . the old one with trepidation. ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would * . create only negligible fill. * . Replace the old reflector with * . the new one. ==== * H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) V( 2, M ) = VT( 2 ) V( 3, M ) = VT( 3 ) END IF END IF END IF 10 CONTINUE * * ==== Generate a 2-by-2 reflection, if needed. ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF( K.EQ.KTOP-1 ) THEN CALL CLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), $ S( 2*M22 ), V( 1, M22 ) ) BETA = V( 1, M22 ) CALL CLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) ELSE BETA = H( K+1, K ) V( 2, M22 ) = H( K+2, K ) CALL CLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF END IF * * ==== Multiply H by reflections from the left ==== * IF( ACCUM ) THEN JBOT = MIN( NDCOL, KBOT ) ELSE IF( WANTT ) THEN JBOT = N ELSE JBOT = KBOT END IF DO 30 J = MAX( KTOP, KRCOL ), JBOT MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) DO 20 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = CONJG( V( 1, M ) )* $ ( H( K+1, J )+CONJG( V( 2, M ) )*H( K+2, J )+ $ CONJG( V( 3, M ) )*H( K+3, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 20 CONTINUE 30 CONTINUE IF( BMP22 ) THEN K = KRCOL + 3*( M22-1 ) DO 40 J = MAX( K+1, KTOP ), JBOT REFSUM = CONJG( V( 1, M22 ) )* $ ( H( K+1, J )+CONJG( V( 2, M22 ) )* $ H( K+2, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 40 CONTINUE END IF * * ==== Multiply H by reflections from the right. * . Delay filling in the last row until the * . vigilant deflation check is complete. ==== * IF( ACCUM ) THEN JTOP = MAX( KTOP, INCOL ) ELSE IF( WANTT ) THEN JTOP = 1 ELSE JTOP = KTOP END IF DO 80 M = MTOP, MBOT IF( V( 1, M ).NE.ZERO ) THEN K = KRCOL + 3*( M-1 ) DO 50 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - $ REFSUM*CONJG( V( 2, M ) ) H( J, K+3 ) = H( J, K+3 ) - $ REFSUM*CONJG( V( 3, M ) ) 50 CONTINUE * IF( ACCUM ) THEN * * ==== Accumulate U. (If necessary, update Z later * . with with an efficient matrix-matrix * . multiply.) ==== * KMS = K - INCOL DO 60 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*CONJG( V( 2, M ) ) U( J, KMS+3 ) = U( J, KMS+3 ) - $ REFSUM*CONJG( V( 3, M ) ) 60 CONTINUE ELSE IF( WANTZ ) THEN * * ==== U is not accumulated, so update Z * . now by multiplying by reflections * . from the right. ==== * DO 70 J = ILOZ, IHIZ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - $ REFSUM*CONJG( V( 2, M ) ) Z( J, K+3 ) = Z( J, K+3 ) - $ REFSUM*CONJG( V( 3, M ) ) 70 CONTINUE END IF END IF 80 CONTINUE * * ==== Special case: 2-by-2 reflection (if needed) ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF ( V( 1, M22 ).NE.ZERO ) THEN DO 90 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* $ H( J, K+2 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - $ REFSUM*CONJG( V( 2, M22 ) ) 90 CONTINUE * IF( ACCUM ) THEN KMS = K - INCOL DO 100 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ $ V( 2, M22 )*U( J, KMS+2 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*CONJG( V( 2, M22 ) ) 100 CONTINUE ELSE IF( WANTZ ) THEN DO 110 J = ILOZ, IHIZ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* $ Z( J, K+2 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - $ REFSUM*CONJG( V( 2, M22 ) ) 110 CONTINUE END IF END IF END IF * * ==== Vigilant deflation check ==== * MSTART = MTOP IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) $ MSTART = MSTART + 1 MEND = MBOT IF( BMP22 ) $ MEND = MEND + 1 IF( KRCOL.EQ.KBOT-2 ) $ MEND = MEND + 1 DO 120 M = MSTART, MEND K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) * * ==== The following convergence test requires that * . the tradition small-compared-to-nearby-diagonals * . criterion and the Ahues & Tisseur (LAWN 122, 1997) * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 * . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) IF( TST1.EQ.RZERO ) THEN IF( K.GE.KTOP+1 ) $ TST1 = TST1 + CABS1( H( K, K-1 ) ) IF( K.GE.KTOP+2 ) $ TST1 = TST1 + CABS1( H( K, K-2 ) ) IF( K.GE.KTOP+3 ) $ TST1 = TST1 + CABS1( H( K, K-3 ) ) IF( K.LE.KBOT-2 ) $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) IF( K.LE.KBOT-3 ) $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) IF( K.LE.KBOT-4 ) $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) END IF IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) $ THEN H12 = MAX( CABS1( H( K+1, K ) ), $ CABS1( H( K, K+1 ) ) ) H21 = MIN( CABS1( H( K+1, K ) ), $ CABS1( H( K, K+1 ) ) ) H11 = MAX( CABS1( H( K+1, K+1 ) ), $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) H22 = MIN( CABS1( H( K+1, K+1 ) ), $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) SCL = H11 + H12 TST2 = H22*( H11 / SCL ) * IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO END IF END IF 120 CONTINUE * * ==== Fill in the last row of each bulge. ==== * MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) DO 130 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) H( K+4, K+1 ) = -REFSUM H( K+4, K+2 ) = -REFSUM*CONJG( V( 2, M ) ) H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*CONJG( V( 3, M ) ) 130 CONTINUE * * ==== End of near-the-diagonal bulge chase. ==== * 140 CONTINUE * * ==== Use U (if accumulated) to update far-from-diagonal * . entries in H. If required, use U to update Z as * . well. ==== * IF( ACCUM ) THEN IF( WANTT ) THEN JTOP = 1 JBOT = N ELSE JTOP = KTOP JBOT = KBOT END IF IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN * * ==== Updates not exploiting the 2-by-2 block * . structure of U. K1 and NU keep track of * . the location and size of U in the special * . cases of introducing bulges and chasing * . bulges off the bottom. In these special * . cases and in case the number of shifts * . is NS = 2, there is no 2-by-2 block * . structure to exploit. ==== * K1 = MAX( 1, KTOP-INCOL ) NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 * * ==== Horizontal Multiply ==== * DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) CALL CGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, $ LDWH ) CALL CLACPY( 'ALL', NU, JLEN, WH, LDWH, $ H( INCOL+K1, JCOL ), LDH ) 150 CONTINUE * * ==== Vertical multiply ==== * DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) CALL CGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL CLACPY( 'ALL', JLEN, NU, WV, LDWV, $ H( JROW, INCOL+K1 ), LDH ) 160 CONTINUE * * ==== Z multiply (also vertical) ==== * IF( WANTZ ) THEN DO 170 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) CALL CGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL CLACPY( 'ALL', JLEN, NU, WV, LDWV, $ Z( JROW, INCOL+K1 ), LDZ ) 170 CONTINUE END IF ELSE * * ==== Updates exploiting U's 2-by-2 block structure. * . (I2, I4, J2, J4 are the last rows and columns * . of the blocks.) ==== * I2 = ( KDU+1 ) / 2 I4 = KDU J2 = I4 - I2 J4 = KDU * * ==== KZS and KNZ deal with the band of zeros * . along the diagonal of one of the triangular * . blocks. ==== * KZS = ( J4-J2 ) - ( NS+1 ) KNZ = NS + 1 * * ==== Horizontal multiply ==== * DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) * * ==== Copy bottom of H to top+KZS of scratch ==== * (The first KZS rows get multiplied by zero.) ==== * CALL CLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), $ LDH, WH( KZS+1, 1 ), LDWH ) * * ==== Multiply by U21**H ==== * CALL CLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) CALL CTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), $ LDWH ) * * ==== Multiply top of H by U11**H ==== * CALL CGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * * ==== Copy top of H to bottom of WH ==== * CALL CLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U21**H ==== * CALL CTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U22 ==== * CALL CGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, $ U( J2+1, I2+1 ), LDU, $ H( INCOL+1+J2, JCOL ), LDH, ONE, $ WH( I2+1, 1 ), LDWH ) * * ==== Copy it back ==== * CALL CLACPY( 'ALL', KDU, JLEN, WH, LDWH, $ H( INCOL+1, JCOL ), LDH ) 180 CONTINUE * * ==== Vertical multiply ==== * DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) * * ==== Copy right of H to scratch (the first KZS * . columns get multiplied by zero) ==== * CALL CLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), $ LDH, WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U21 ==== * CALL CLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) CALL CTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL CGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, $ LDWV ) * * ==== Copy left of H to right of scratch ==== * CALL CLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, $ WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL CTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U22 ==== * CALL CGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ H( JROW, INCOL+1+J2 ), LDH, $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), $ LDWV ) * * ==== Copy it back ==== * CALL CLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ H( JROW, INCOL+1 ), LDH ) 190 CONTINUE * * ==== Multiply Z (also vertical) ==== * IF( WANTZ ) THEN DO 200 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) * * ==== Copy right of Z to left of scratch (first * . KZS columns get multiplied by zero) ==== * CALL CLACPY( 'ALL', JLEN, KNZ, $ Z( JROW, INCOL+1+J2 ), LDZ, $ WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U12 ==== * CALL CLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, $ LDWV ) CALL CTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL CGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, $ WV, LDWV ) * * ==== Copy left of Z to right of scratch ==== * CALL CLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), $ LDZ, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL CTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), $ LDWV ) * * ==== Multiply by U22 ==== * CALL CGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ Z( JROW, INCOL+1+J2 ), LDZ, $ U( J2+1, I2+1 ), LDU, ONE, $ WV( 1, 1+I2 ), LDWV ) * * ==== Copy the result back to Z ==== * CALL CLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ Z( JROW, INCOL+1 ), LDZ ) 200 CONTINUE END IF END IF END IF 210 CONTINUE * * ==== End of CLAQR5 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clarf.f000066400000000000000000000143101522610125300260400ustar00rootroot00000000000000*> \brief \b CLARF applies an elementary reflector to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * COMPLEX TAU * .. * .. Array Arguments .. * COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARF applies a complex elementary reflector H to a complex M-by-N *> matrix C, from either the left or the right. H is represented in the *> form *> *> H = I - tau * v * v**H *> *> where tau is a complex scalar and v is a complex vector. *> *> If tau = 0, then H is taken to be the unit matrix. *> *> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead *> tau. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of H. V is not used if *> TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \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, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER INCV, LDC, M, N COMPLEX TAU * .. * .. Array Arguments .. COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILACLR, ILACLC EXTERNAL LSAME, ILACLR, ILACLC * .. * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) LASTV = 0 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end ! of V. IF( APPLYLEFT ) THEN LASTV = M ELSE LASTV = N END IF IF( INCV.GT.0 ) THEN I = 1 + (LASTV-1) * INCV ELSE I = 1 END IF ! Look for the last non-zero row in V. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). LASTC = ILACLC(LASTV, N, C, LDC) ELSE ! Scan for the last non-zero row in C(:,1:lastv). LASTC = ILACLR(M, LASTV, C, LDC) END IF END IF ! Note that lastc.eq.0 renders the BLAS operations null; no special ! case is needed at this level. IF( APPLYLEFT ) THEN * * Form H * C * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) * CALL CGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, $ C, LDC, V, INCV, ZERO, WORK, 1 ) * * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H * CALL CGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) * CALL CGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, $ V, INCV, ZERO, WORK, 1 ) * * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H * CALL CGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of CLARF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clarfb.f000066400000000000000000000532411522610125300262100ustar00rootroot00000000000000*> \brief \b CLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARFB applies a complex block reflector H or its transpose H**H to a *> complex M-by-N matrix C, from either the left or the right. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**H from the Left *> = 'R': apply H or H**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'C': apply H**H (Conjugate transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columnwise *> = 'R': Rowwise *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T (= the number of elementary *> reflectors whose product defines the block reflector). *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The matrix V. See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is COMPLEX array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \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 H*C or H**H*C or C*H or C*H**H. *> \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, dimension (LDWORK,K) *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= max(1,N); *> if SIDE = 'R', LDWORK >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2013 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored; the corresponding *> array elements are modified but restored on exit. The rest of the *> array is not used. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C1**H * DO 10 J = 1, K CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL CLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**H *V2 * CALL CGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C( K+1, 1 ), LDC, $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * IF( N.GT.K ) THEN * * C2 := C2 - W * V2**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C2**H * DO 70 J = 1, K CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) CALL CLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1 * CALL CGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T**H or W * T * CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, C, LDC ) END IF * * W := W * V2**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ CONJG( WORK( I, J ) ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * IF( N.GT.K ) THEN * * C1 := C1 - W * V1**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, $ C, LDC ) END IF * * W := W * V2**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C1**H * DO 130 J = 1, K CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL CLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**H * V2**H * CALL CGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T**H or W * T * CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * IF( M.GT.K ) THEN * * C2 := C2 - V2**H * W**H * CALL CGEMM( 'Conjugate transpose', $ 'Conjugate transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', M, $ K, N-K, ONE, C( 1, K+1 ), LDC, $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C2**H * DO 190 J = 1, K CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) CALL CLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL CGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, C, $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * IF( M.GT.K ) THEN * * C1 := C1 - V1**H * W**H * CALL CGEMM( 'Conjugate transpose', $ 'Conjugate transpose', M-K, N, K, -ONE, V, $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ CONJG( WORK( I, J ) ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', M, $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T or W * T**H * CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of CLARFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clarfg.f000066400000000000000000000124101522610125300262060ustar00rootroot00000000000000*> \brief \b CLARFG generates an elementary reflector (Householder matrix). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARFG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU ) * * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX ALPHA, TAU * .. * .. Array Arguments .. * COMPLEX X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARFG generates a complex elementary reflector H of order n, such *> that *> *> H**H * ( alpha ) = ( beta ), H**H * H = I. *> ( x ) ( 0 ) *> *> where alpha and beta are scalars, with beta real, and x is an *> (n-1)-element complex vector. H is represented in the form *> *> H = I - tau * ( 1 ) * ( 1 v**H ) , *> ( v ) *> *> where tau is a complex scalar and v is a complex (n-1)-element *> vector. Note that H is not hermitian. *> *> If the elements of x are all zero and alpha is real, then tau = 0 *> and H is taken to be the unit matrix. *> *> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the elementary reflector. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is COMPLEX *> On entry, the value alpha. *> On exit, it is overwritten with the value beta. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX array, dimension *> (1+(N-2)*abs(INCX)) *> On entry, the vector x. *> On exit, it is overwritten with the vector v. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX *> The value tau. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N COMPLEX ALPHA, TAU * .. * .. Array Arguments .. COMPLEX X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER J, KNT REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. REAL SCNRM2, SLAMCH, SLAPY3 COMPLEX CLADIV EXTERNAL SCNRM2, SLAMCH, SLAPY3, CLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN * .. * .. External Subroutines .. EXTERNAL CSCAL, CSSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = SCNRM2( N-1, X, INCX ) ALPHR = REAL( ALPHA ) ALPHI = AIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' ) RSAFMN = ONE / SAFMIN * KNT = 0 IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * 10 CONTINUE KNT = KNT + 1 CALL CSSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = SCNRM2( N-1, X, INCX ) ALPHA = CMPLX( ALPHR, ALPHI ) BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) END IF TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA ) CALL CSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * DO 20 J = 1, KNT BETA = BETA*SAFMIN 20 CONTINUE ALPHA = BETA END IF * RETURN * * End of CLARFG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clarft.f000066400000000000000000000242071522610125300262320ustar00rootroot00000000000000*> \brief \b CLARFT forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARFT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARFT forms the triangular factor T of a complex block reflector H *> of order n, which is defined as a product of k elementary reflectors. *> *> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; *> *> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. *> *> If STOREV = 'C', the vector which defines the elementary reflector *> H(i) is stored in the i-th column of the array V, and *> *> H = I - V * T * V**H *> *> If STOREV = 'R', the vector which defines the elementary reflector *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**H * T * V *> \endverbatim * * Arguments: * ========== * *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies the order in which the elementary reflectors are *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): *> = 'C': columnwise *> = 'R': rowwise *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the block reflector H. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the triangular factor T (= the number of *> elementary reflectors). K >= 1. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,N) if STOREV = 'R' *> The matrix V. See further details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX array, dimension (LDT,K) *> The k by k triangular factor T of the block reflector. *> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is *> lower triangular. The rest of the array is not used. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. EXTERNAL CGEMM, CGEMV, CTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN PREVLASTV = N DO I = 1, K PREVLASTV = MAX( PREVLASTV, I ) IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = 1, I T( J, I ) = ZERO END DO ELSE * * general case * IF( LSAME( STOREV, 'C' ) ) THEN * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) 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, $ V( I+1, I ), 1, $ ONE, T( 1, I ), 1 ) ELSE * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) 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 ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL CTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) IF( I.GT.1 ) THEN PREVLASTV = MAX( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF END DO ELSE PREVLASTV = 1 DO I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = I, K T( J, I ) = ZERO END DO ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) 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) * CALL CGEMV( 'Conjugate transpose', N-K+I-J, K-I, $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), $ 1, ONE, T( I+1, I ), 1 ) ELSE * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) 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 ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL CTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) IF( I.GT.1 ) THEN PREVLASTV = MIN( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF T( I, I ) = TAU( I ) END IF END DO END IF RETURN * * End of CLARFT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clarfx.f000066400000000000000000000504661522610125300262440ustar00rootroot00000000000000*> \brief \b CLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARFX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N * COMPLEX TAU * .. * .. Array Arguments .. * COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARFX applies a complex elementary reflector H to a complex m by n *> matrix C, from either the left or the right. H is represented in the *> form *> *> H = I - tau * v * v**H *> *> where tau is a complex scalar and v is a complex vector. *> *> If tau = 0, then H is taken to be the unit matrix *> *> This version uses inline code if H has order < 11. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension (M) if SIDE = 'L' *> or (N) if SIDE = 'R' *> The vector v in the representation of H. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDA >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> WORK is not referenced if H has order < 11. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER LDC, M, N COMPLEX TAU * .. * .. Array Arguments .. COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER J COMPLEX SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLARF * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * CALL CLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*CONJG( V( 1 ) ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) V5 = CONJG( V( 5 ) ) T5 = TAU*CONJG( V5 ) DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) V5 = CONJG( V( 5 ) ) T5 = TAU*CONJG( V5 ) V6 = CONJG( V( 6 ) ) T6 = TAU*CONJG( V6 ) DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) V5 = CONJG( V( 5 ) ) T5 = TAU*CONJG( V5 ) V6 = CONJG( V( 6 ) ) T6 = TAU*CONJG( V6 ) V7 = CONJG( V( 7 ) ) T7 = TAU*CONJG( V7 ) DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) V5 = CONJG( V( 5 ) ) T5 = TAU*CONJG( V5 ) V6 = CONJG( V( 6 ) ) T6 = TAU*CONJG( V6 ) V7 = CONJG( V( 7 ) ) T7 = TAU*CONJG( V7 ) V8 = CONJG( V( 8 ) ) T8 = TAU*CONJG( V8 ) DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) V5 = CONJG( V( 5 ) ) T5 = TAU*CONJG( V5 ) V6 = CONJG( V( 6 ) ) T6 = TAU*CONJG( V6 ) V7 = CONJG( V( 7 ) ) T7 = TAU*CONJG( V7 ) V8 = CONJG( V( 8 ) ) T8 = TAU*CONJG( V8 ) V9 = CONJG( V( 9 ) ) T9 = TAU*CONJG( V9 ) DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = CONJG( V( 1 ) ) T1 = TAU*CONJG( V1 ) V2 = CONJG( V( 2 ) ) T2 = TAU*CONJG( V2 ) V3 = CONJG( V( 3 ) ) T3 = TAU*CONJG( V3 ) V4 = CONJG( V( 4 ) ) T4 = TAU*CONJG( V4 ) V5 = CONJG( V( 5 ) ) T5 = TAU*CONJG( V5 ) V6 = CONJG( V( 6 ) ) T6 = TAU*CONJG( V6 ) V7 = CONJG( V( 7 ) ) T7 = TAU*CONJG( V7 ) V8 = CONJG( V( 8 ) ) T8 = TAU*CONJG( V8 ) V9 = CONJG( V( 9 ) ) T9 = TAU*CONJG( V9 ) V10 = CONJG( V( 10 ) ) T10 = TAU*CONJG( V10 ) DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * CALL CLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*CONJG( V( 1 ) ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) V5 = V( 5 ) T5 = TAU*CONJG( V5 ) DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) V5 = V( 5 ) T5 = TAU*CONJG( V5 ) V6 = V( 6 ) T6 = TAU*CONJG( V6 ) DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) V5 = V( 5 ) T5 = TAU*CONJG( V5 ) V6 = V( 6 ) T6 = TAU*CONJG( V6 ) V7 = V( 7 ) T7 = TAU*CONJG( V7 ) DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) V5 = V( 5 ) T5 = TAU*CONJG( V5 ) V6 = V( 6 ) T6 = TAU*CONJG( V6 ) V7 = V( 7 ) T7 = TAU*CONJG( V7 ) V8 = V( 8 ) T8 = TAU*CONJG( V8 ) DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) V5 = V( 5 ) T5 = TAU*CONJG( V5 ) V6 = V( 6 ) T6 = TAU*CONJG( V6 ) V7 = V( 7 ) T7 = TAU*CONJG( V7 ) V8 = V( 8 ) T8 = TAU*CONJG( V8 ) V9 = V( 9 ) T9 = TAU*CONJG( V9 ) DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*CONJG( V1 ) V2 = V( 2 ) T2 = TAU*CONJG( V2 ) V3 = V( 3 ) T3 = TAU*CONJG( V3 ) V4 = V( 4 ) T4 = TAU*CONJG( V4 ) V5 = V( 5 ) T5 = TAU*CONJG( V5 ) V6 = V( 6 ) T6 = TAU*CONJG( V6 ) V7 = V( 7 ) T7 = TAU*CONJG( V7 ) V8 = V( 8 ) T8 = TAU*CONJG( V8 ) V9 = V( 9 ) T9 = TAU*CONJG( V9 ) V10 = V( 10 ) T10 = TAU*CONJG( V10 ) DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 RETURN * * End of CLARFX * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clarnv.f000066400000000000000000000127441522610125300262470ustar00rootroot00000000000000*> \brief \b CLARNV returns a vector of random numbers from a uniform or normal distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARNV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARNV( IDIST, ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER IDIST, N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * COMPLEX X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARNV returns a vector of n random complex numbers from a uniform or *> normal distribution. *> \endverbatim * * Arguments: * ========== * *> \param[in] IDIST *> \verbatim *> IDIST is INTEGER *> Specifies the distribution of the random numbers: *> = 1: real and imaginary parts each uniform (0,1) *> = 2: real and imaginary parts each uniform (-1,1) *> = 3: real and imaginary parts each normal (0,1) *> = 4: uniformly distributed on the disc abs(z) < 1 *> = 5: uniformly distributed on the circle abs(z) = 1 *> \endverbatim *> *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is COMPLEX array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine calls the auxiliary routine SLARUV to generate random *> real numbers from a uniform (0,1) distribution, in batches of up to *> 128 using vectorisable code. The Box-Muller method is used to *> transform numbers from a uniform to a normal distribution. *> \endverbatim *> * ===================================================================== SUBROUTINE CLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.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 IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) INTEGER LV PARAMETER ( LV = 128 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IV * .. * .. Local Arrays .. REAL U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, EXP, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL SLARUV * .. * .. Executable Statements .. * DO 60 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) * * Call SLARUV to generate 2*IL real numbers from a uniform (0,1) * distribution (2*IL <= LV) * CALL SLARUV( ISEED, 2*IL, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = CMPLX( U( 2*I-1 ), U( 2*I ) ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = CMPLX( TWO*U( 2*I-1 )-ONE, $ TWO*U( 2*I )-ONE ) 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) ) 30 CONTINUE ELSE IF( IDIST.EQ.4 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit disk * DO 40 I = 1, IL X( IV+I-1 ) = SQRT( U( 2*I-1 ) )* $ EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) ) 40 CONTINUE ELSE IF( IDIST.EQ.5 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit circle * DO 50 I = 1, IL X( IV+I-1 ) = EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) ) 50 CONTINUE END IF 60 CONTINUE RETURN * * End of CLARNV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clartg.f000066400000000000000000000162571522610125300262410ustar00rootroot00000000000000*> \brief \b CLARTG generates a plane rotation with real cosine and complex sine. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLARTG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARTG( F, G, CS, SN, R ) * * .. Scalar Arguments .. * REAL CS * COMPLEX F, G, R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLARTG generates a plane rotation so that *> *> [ CS SN ] [ F ] [ R ] *> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. *> [ -SN CS ] [ G ] [ 0 ] *> *> This is a faster version of the BLAS1 routine CROTG, except for *> the following differences: *> F and G are unchanged on return. *> If G=0, then CS=1 and SN=0. *> If F=0, then CS=0 and SN is chosen so that R is real. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is COMPLEX *> The first component of vector to be rotated. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is COMPLEX *> The second component of vector to be rotated. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is REAL *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is COMPLEX *> The sine of the rotation. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is COMPLEX *> The nonzero component of the rotated vector. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel *> *> This version has a few statements commented out for thread safety *> (machine parameters are computed on each entry). 10 feb 03, SJH. *> \endverbatim *> * ===================================================================== SUBROUTINE CLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL CS COMPLEX F, G, R, SN * .. * * ===================================================================== * * .. Parameters .. REAL TWO, ONE, ZERO PARAMETER ( TWO = 2.0E+0, ONE = 1.0E+0, ZERO = 0.0E+0 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I REAL D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE COMPLEX FF, FS, GS * .. * .. External Functions .. REAL SLAMCH, SLAPY2 LOGICAL SISNAN EXTERNAL SLAMCH, SLAPY2, SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL, $ SQRT * .. * .. Statement Functions .. REAL ABS1, ABSSQ * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) ) ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2 * .. * .. Executable Statements .. * SAFMIN = SLAMCH( 'S' ) EPS = SLAMCH( 'E' ) SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( SLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G COUNT = 0 IF( SCALE.GE.SAFMX2 ) THEN 10 CONTINUE COUNT = COUNT + 1 FS = FS*SAFMN2 GS = GS*SAFMN2 SCALE = SCALE*SAFMN2 IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN IF( G.EQ.CZERO.OR.SISNAN( ABS( G ) ) ) THEN CS = ONE SN = CZERO R = F RETURN END IF 20 CONTINUE COUNT = COUNT - 1 FS = FS*SAFMX2 GS = GS*SAFMX2 SCALE = SCALE*SAFMX2 IF( SCALE.LE.SAFMN2 ) $ GO TO 20 END IF F2 = ABSSQ( FS ) G2 = ABSSQ( GS ) IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN * * This is a rare case: F is very small. * IF( F.EQ.CZERO ) THEN CS = ZERO R = SLAPY2( REAL( G ), AIMAG( G ) ) * Do complex/real division explicitly with two real divisions D = SLAPY2( REAL( GS ), AIMAG( GS ) ) SN = CMPLX( REAL( GS ) / D, -AIMAG( GS ) / D ) RETURN END IF F2S = SLAPY2( REAL( FS ), AIMAG( FS ) ) * G2 and G2S are accurate * G2 is at least SAFMIN, and G2S is at least SAFMN2 G2S = SQRT( G2 ) * Error in CS from underflow in F2S is at most * UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS * If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, * and so CS .lt. sqrt(SAFMIN) * If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN * and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) * Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S CS = F2S / G2S * Make sure abs(FF) = 1 * Do complex/real division explicitly with 2 real divisions IF( ABS1( F ).GT.ONE ) THEN D = SLAPY2( REAL( F ), AIMAG( F ) ) FF = CMPLX( REAL( F ) / D, AIMAG( F ) / D ) ELSE DR = SAFMX2*REAL( F ) DI = SAFMX2*AIMAG( F ) D = SLAPY2( DR, DI ) FF = CMPLX( DR / D, DI / D ) END IF SN = FF*CMPLX( REAL( GS ) / G2S, -AIMAG( GS ) / G2S ) R = CS*F + SN*G ELSE * * This is the most common case. * Neither F2 nor F2/G2 are less than SAFMIN * F2S cannot overflow, and it is accurate * F2S = SQRT( ONE+G2 / F2 ) * Do the F2S(real)*FS(complex) multiply with two real multiplies R = CMPLX( F2S*REAL( FS ), F2S*AIMAG( FS ) ) CS = ONE / F2S D = F2 + G2 * Do complex/real division explicitly with two real divisions SN = CMPLX( REAL( R ) / D, AIMAG( R ) / D ) SN = SN*CONJG( GS ) IF( COUNT.NE.0 ) THEN IF( COUNT.GT.0 ) THEN DO 30 I = 1, COUNT R = R*SAFMX2 30 CONTINUE ELSE DO 40 I = 1, -COUNT R = R*SAFMN2 40 CONTINUE END IF END IF END IF RETURN * * End of CLARTG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clascl.f000066400000000000000000000234001522610125300262120ustar00rootroot00000000000000*> \brief \b CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLASCL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL CFROM, CTO * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLASCL multiplies the M by N complex matrix A by the real scalar *> CTO/CFROM. This is done without over/underflow as long as the final *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that *> A may be full, upper triangular, lower triangular, upper Hessenberg, *> or banded. *> \endverbatim * * Arguments: * ========== * *> \param[in] TYPE *> \verbatim *> TYPE is CHARACTER*1 *> TYPE indices the storage type of the input matrix. *> = 'G': A is a full matrix. *> = 'L': A is a lower triangular matrix. *> = 'U': A is an upper triangular matrix. *> = 'H': A is an upper Hessenberg matrix. *> = 'B': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the lower *> half stored. *> = 'Q': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the upper *> half stored. *> = 'Z': A is a band matrix with lower bandwidth KL and upper *> bandwidth KU. See CGBTRF for storage details. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The lower bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The upper bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] CFROM *> \verbatim *> CFROM is REAL *> \endverbatim *> *> \param[in] CTO *> \verbatim *> CTO is REAL *> *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed *> without over/underflow if the final result CTO*A(I,J)/CFROM *> can be represented without over/underflow. CFROM must be *> nonzero. *> \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,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> The matrix to be multiplied by CTO/CFROM. See TYPE for the *> storage type. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> 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 *> \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 June 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 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 TYPE INTEGER INFO, KL, KU, LDA, M, N REAL CFROM, CTO * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME, SISNAN REAL SLAMCH EXTERNAL LSAME, SLAMCH, SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN INFO = -4 ELSE IF( SISNAN(CTO) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM IF( CFROM1.EQ.CFROMC ) THEN ! CFROMC is an inf. Multiply by a correctly signed zero for ! finite CTOC, or a NaN if CTOC is infinite. MUL = CTOC / CFROMC DONE = .TRUE. CTO1 = CTOC ELSE CTO1 = CTOC / BIGNUM IF( CTO1.EQ.CTOC ) THEN ! CTOC is either 0 or an inf. In both cases, CTOC itself ! serves as the correct multiplication factor. MUL = CTOC DONE = .TRUE. CFROMC = ONE ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of CLASCL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claset.f000066400000000000000000000113451522610125300262310ustar00rootroot00000000000000*> \brief \b CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLASET + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N * COMPLEX ALPHA, BETA * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLASET initializes a 2-D array A to BETA on the diagonal and *> ALPHA on the offdiagonals. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be set. *> = 'U': Upper triangular part is set. The lower triangle *> is unchanged. *> = 'L': Lower triangular part is set. The upper triangle *> is unchanged. *> Otherwise: All of the matrix A is set. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the number of rows of A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the number of columns of A. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is COMPLEX *> All the offdiagonal array elements are set to ALPHA. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is COMPLEX *> All the diagonal array elements are set to BETA. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the m by n matrix A. *> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; *> A(i,i) = BETA , 1 <= i <= min(m,n) *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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, M, N COMPLEX ALPHA, BETA * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the diagonal to BETA and the strictly upper triangular * part of the array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( N, M ) A( I, I ) = BETA 30 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the diagonal to BETA and the strictly lower triangular * part of the array to ALPHA. * DO 50 J = 1, MIN( M, N ) DO 40 I = J + 1, M A( I, J ) = ALPHA 40 CONTINUE 50 CONTINUE DO 60 I = 1, MIN( N, M ) A( I, I ) = BETA 60 CONTINUE * ELSE * * Set the array to BETA on the diagonal and ALPHA on the * offdiagonal. * DO 80 J = 1, N DO 70 I = 1, M A( I, J ) = ALPHA 70 CONTINUE 80 CONTINUE DO 90 I = 1, MIN( M, N ) A( I, I ) = BETA 90 CONTINUE END IF * RETURN * * End of CLASET * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clasr.f000066400000000000000000000353761522610125300260740ustar00rootroot00000000000000*> \brief \b CLASR applies a sequence of plane rotations to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLASR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N * .. * .. Array Arguments .. * REAL C( * ), S( * ) * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLASR applies a sequence of real plane rotations to a complex 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 ) *> ( c(k) s(k) ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( c(k) s(k) ) *> ( 1 ) *> ( ... ) *> ( 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> Specifies whether the plane rotation matrix P is applied to *> A on the left or the right. *> = 'L': Left, compute A := P*A *> = 'R': Right, compute A:= A*P**T *> \endverbatim *> *> \param[in] PIVOT *> \verbatim *> PIVOT is CHARACTER*1 *> Specifies the plane for which P(k) is a plane rotation *> matrix. *> = 'V': Variable pivot, the plane (k,k+1) *> = 'T': Top pivot, the plane (1,k+1) *> = 'B': Bottom pivot, the plane (k,z) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies whether P is a forward or backward sequence of *> plane rotations. *> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) *> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. If m <= 1, an immediate *> return is effected. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. If n <= 1, an *> immediate return is effected. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is REAL array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The cosines c(k) of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is REAL array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The sines s(k) of the plane rotations. The 2-by-2 plane *> rotation part of the matrix P(k), R(k), has the form *> R(k) = ( c(k) s(k) ) *> ( -s(k) c(k) ). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> The M-by-N matrix A. On exit, A is overwritten by P*A if *> SIDE = 'R' or by A*P**T if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. REAL C( * ), S( * ) COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J REAL CTEMP, STEMP COMPLEX TEMP * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P**T * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of CLASR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/classq.f000066400000000000000000000112051522610125300262370ustar00rootroot00000000000000*> \brief \b CLASSQ updates a sum of squares represented in scaled form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLASSQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) * * .. Scalar Arguments .. * INTEGER INCX, N * REAL SCALE, SUMSQ * .. * .. Array Arguments .. * COMPLEX X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLASSQ returns the values scl and ssq such that *> *> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, *> *> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is *> assumed to be at least unity and the value of ssq will then satisfy *> *> 1.0 .le. ssq .le. ( sumsq + 2*n ). *> *> scale is assumed to be non-negative and scl returns the value *> *> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), *> i *> *> scale and sumsq must be supplied in SCALE and SUMSQ respectively. *> SCALE and SUMSQ are overwritten by scl and ssq respectively. *> *> The routine makes only one pass through the vector X. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements to be used from the vector X. *> \endverbatim *> *> \param[in] X *> \verbatim *> X is COMPLEX array, dimension (N) *> The vector x as described above. *> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of the vector X. *> INCX > 0. *> \endverbatim *> *> \param[in,out] SCALE *> \verbatim *> SCALE is REAL *> On entry, the value scale in the equation above. *> On exit, SCALE is overwritten with the value scl . *> \endverbatim *> *> \param[in,out] SUMSQ *> \verbatim *> SUMSQ is REAL *> On entry, the value sumsq in the equation above. *> On exit, SUMSQ is overwritten with the value ssq . *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N REAL SCALE, SUMSQ * .. * .. Array Arguments .. COMPLEX X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER IX REAL TEMP1 * .. * .. External Functions .. LOGICAL SISNAN EXTERNAL SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX TEMP1 = ABS( REAL( X( IX ) ) ) IF( TEMP1.GT.ZERO.OR.SISNAN( TEMP1 ) ) THEN IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF TEMP1 = ABS( AIMAG( X( IX ) ) ) IF( TEMP1.GT.ZERO.OR.SISNAN( TEMP1 ) ) THEN IF( SCALE.LT.TEMP1 .OR. SISNAN( TEMP1 ) ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF 10 CONTINUE END IF * RETURN * * End of CLASSQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/claswp.f000066400000000000000000000117161522610125300262510ustar00rootroot00000000000000*> \brief \b CLASWP performs a series of row interchanges on a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLASWP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLASWP performs a series of row interchanges on the matrix A. *> One row interchange is initiated for each of rows K1 through K2 of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the matrix of column dimension N to which the row *> interchanges will be applied. *> On exit, the permuted matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> \endverbatim *> *> \param[in] K1 *> \verbatim *> K1 is INTEGER *> The first element of IPIV for which a row interchange will *> be done. *> \endverbatim *> *> \param[in] K2 *> \verbatim *> K2 is INTEGER *> (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 (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 *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of IPIV. If IPIV *> is negative, the pivots are applied in reverse order. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by *> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA *> \endverbatim *> * ===================================================================== SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 COMPLEX TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of CLASWP * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clatdf.f000066400000000000000000000250171522610125300262140ustar00rootroot00000000000000*> \brief \b CLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLATDF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) * * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * REAL RDSCAL, RDSUM * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * COMPLEX RHS( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLATDF computes the contribution to the reciprocal Dif-estimate *> by solving for x in Z * x = b, where b is chosen such that the norm *> of x is as large as possible. It is assumed that LU decomposition *> of Z has been computed by CGETC2. On entry RHS = f holds the *> contribution from earlier solved sub-systems, and on return RHS = x. *> *> The factorization of Z returned by CGETC2 has the form *> Z = P * L * U * Q, where P and Q are permutation matrices. L is lower *> triangular with unit diagonal elements and U is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> IJOB = 2: First compute an approximative null-vector e *> of Z using CGECON, e is normalized and solve for *> 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 chosen as either +1 or *> -1. Default. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Z. *> \endverbatim *> *> \param[in] Z *> \verbatim *> 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 *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is REAL *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by CTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is REAL *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when CTGSY2 is called by *> CTGSYL. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> This routine is a further developed implementation of algorithm *> BSOLVE in [1] using complete pivoting in the LU factorization. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] Bo Kagstrom and Lars Westin, *> Generalized Schur Methods with Condition Estimators for *> Solving the Generalized Sylvester Equation, IEEE Transactions *> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. *> *> [2] Peter Poromaa, *> On Efficient and Robust Estimators for the Separation *> between two Regular Matrix Pairs with Applications in *> Condition Estimation. Report UMINF-95.05, Department of *> Computing Science, Umea University, S-901 87 Umea, Sweden, *> 1995. * * ===================================================================== SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER IJOB, LDZ, N REAL RDSCAL, RDSUM * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) COMPLEX RHS( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXDIM PARAMETER ( MAXDIM = 2 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) COMPLEX CONE PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, INFO, J, K REAL RTEMP, SCALE, SMINU, SPLUS COMPLEX BM, BP, PMONE, TEMP * .. * .. Local Arrays .. REAL RWORK( MAXDIM ) COMPLEX WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) * .. * .. External Subroutines .. EXTERNAL CAXPY, CCOPY, CGECON, CGESC2, CLASSQ, CLASWP, $ CSCAL * .. * .. External Functions .. REAL SCASUM COMPLEX CDOTC EXTERNAL SCASUM, CDOTC * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, SQRT * .. * .. Executable Statements .. * IF( IJOB.NE.2 ) THEN * * Apply permutations IPIV to RHS * CALL CLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) * * Solve for L-part choosing RHS either to +1 or -1. * PMONE = -CONE DO 10 J = 1, N - 1 BP = RHS( J ) + CONE BM = RHS( J ) - CONE SPLUS = ONE * * Lockahead for L- part RHS(1:N-1) = +-1 * SPLUS and SMIN computed more efficiently than in BSOLVE[1]. * SPLUS = SPLUS + REAL( CDOTC( N-J, Z( J+1, J ), 1, Z( J+1, $ J ), 1 ) ) SMINU = REAL( CDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) ) SPLUS = SPLUS*REAL( RHS( J ) ) IF( SPLUS.GT.SMINU ) THEN RHS( J ) = BP ELSE IF( SMINU.GT.SPLUS ) THEN RHS( J ) = BM ELSE * * In this case the updating sums are equal and we can * choose RHS(J) +1 or -1. The first time this happens we * choose -1, thereafter +1. This is a simple way to get * good estimates of matrices like Byers well-known example * (see [1]). (Not done in BSOLVE.) * RHS( J ) = RHS( J ) + PMONE PMONE = CONE END IF * * Compute the remaining r.h.s. * TEMP = -RHS( J ) CALL CAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) 10 CONTINUE * * Solve for U- part, lockahead for RHS(N) = +-1. This is not done * In BSOLVE and will hopefully give us a better estimate because * any ill-conditioning of the original matrix is transfered to U * and not to L. U(N, N) is an approximation to sigma_min(LU). * CALL CCOPY( N-1, RHS, 1, WORK, 1 ) WORK( N ) = RHS( N ) + CONE RHS( N ) = RHS( N ) - CONE SPLUS = ZERO SMINU = ZERO DO 30 I = N, 1, -1 TEMP = CONE / Z( I, I ) WORK( I ) = WORK( I )*TEMP RHS( I ) = RHS( I )*TEMP DO 20 K = I + 1, N WORK( I ) = WORK( I ) - WORK( K )*( Z( I, K )*TEMP ) RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) 20 CONTINUE SPLUS = SPLUS + ABS( WORK( I ) ) SMINU = SMINU + ABS( RHS( I ) ) 30 CONTINUE IF( SPLUS.GT.SMINU ) $ CALL CCOPY( N, WORK, 1, RHS, 1 ) * * Apply the permutations JPIV to the computed solution (RHS) * CALL CLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) * * Compute the sum of squares * CALL CLASSQ( N, RHS, 1, RDSCAL, RDSUM ) RETURN END IF * * ENTRY IJOB = 2 * * Compute approximate nullvector XM of Z * CALL CGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO ) CALL CCOPY( N, WORK( N+1 ), 1, XM, 1 ) * * Compute RHS * CALL CLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) TEMP = CONE / SQRT( CDOTC( N, XM, 1, XM, 1 ) ) CALL CSCAL( N, TEMP, XM, 1 ) CALL CCOPY( N, XM, 1, XP, 1 ) CALL CAXPY( N, CONE, RHS, 1, XP, 1 ) CALL CAXPY( N, -CONE, XM, 1, RHS, 1 ) CALL CGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE ) CALL CGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE ) IF( SCASUM( N, XP, 1 ).GT.SCASUM( N, RHS, 1 ) ) $ CALL CCOPY( N, XP, 1, RHS, 1 ) * * Compute the sum of squares * CALL CLASSQ( N, RHS, 1, RDSCAL, RDSUM ) RETURN * * End of CLATDF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clatrs.f000066400000000000000000000731221522610125300262470ustar00rootroot00000000000000*> \brief \b CLATRS solves a triangular system of equations with the scale factor set to prevent overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CLATRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL SCALE * .. * .. Array Arguments .. * REAL CNORM( * ) * COMPLEX A( LDA, * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CLATRS solves one of the triangular systems *> *> A * x = s*b, A**T * x = s*b, or A**H * x = s*b, *> *> with scaling to prevent overflow. Here A is an upper or lower *> triangular matrix, A**T denotes the transpose of A, A**H denotes the *> conjugate transpose of A, x and b are n-element vectors, and s is a *> scaling factor, usually less than or equal to 1, chosen so that the *> components of x will be less than the overflow threshold. If the *> unscaled problem will not cause overflow, the Level 2 BLAS routine *> CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), *> then s is set to 0 and a non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T * x = s*b (Transpose) *> = 'C': Solve A**H * x = s*b (Conjugate transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \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) *> The triangular matrix A. If UPLO = 'U', the leading n by n *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading n by n lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max (1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> The scaling factor s for the triangular system *> A * x = s*b, A**T * x = s*b, or A**H * x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is REAL array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-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 complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, CTRSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T *x = b or *> A**H *x = b. The basic algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N REAL SCALE * .. * .. Array Arguments .. REAL CNORM( * ) COMPLEX A( LDA, * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0, $ TWO = 2.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, $ XBND, XJ, XMAX COMPLEX CSUMJ, TJJS, USCAL, ZDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ICAMAX, ISAMAX REAL SCASUM, SLAMCH COMPLEX CDOTC, CDOTU, CLADIV EXTERNAL LSAME, ICAMAX, ISAMAX, SCASUM, SLAMCH, CDOTC, $ CDOTU, CLADIV * .. * .. External Subroutines .. EXTERNAL CAXPY, CSSCAL, CTRSV, SLABAD, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL * .. * .. Statement Functions .. REAL CABS1, CABS2 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) CABS2( ZDUM ) = ABS( REAL( ZDUM ) / 2. ) + $ ABS( AIMAG( ZDUM ) / 2. ) * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = SLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM / SLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = SCASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = SCASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM/2. * IMAX = ISAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM*HALF ) THEN TSCAL = ONE ELSE TSCAL = HALF / ( SMLNUM*TMAX ) CALL SSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine CTRSV can be used. * XMAX = ZERO DO 30 J = 1, N XMAX = MAX( XMAX, CABS2( X( J ) ) ) 30 CONTINUE XBND = XMAX * IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 60 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = G(j-1) / abs(A(j,j)) * XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF * IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 40 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 50 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 50 CONTINUE END IF 60 CONTINUE * ELSE * * Compute the growth in A**T * x = b or A**H * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 90 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF 70 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 80 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 80 CONTINUE END IF 90 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL CTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = ( BIGNUM*HALF ) / XMAX CALL CSSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM ELSE XMAX = XMAX*TWO END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 105 END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = CLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = CLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 100 I = 1, N X( I ) = ZERO 100 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 105 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL CSSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL CAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = ICAMAX( J-1, X, 1 ) XMAX = CABS1( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL CAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + ICAMAX( N-J, X( J+1 ), 1 ) XMAX = CABS1( X( I ) ) END IF END IF 110 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * x = b * DO 150 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = CLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.CMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call CDOTU to perform the dot product. * IF( UPPER ) THEN CSUMJ = CDOTU( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = CDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 120 I = 1, J - 1 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 120 CONTINUE ELSE IF( J.LT.N ) THEN DO 130 I = J + 1, N CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.CMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 145 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**T *x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 145 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = CLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 150 CONTINUE * ELSE * * Solve A**H * x = b * DO 190 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = CONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = CLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.CMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call CDOTC to perform the dot product. * IF( UPPER ) THEN CSUMJ = CDOTC( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = CDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 160 I = 1, J - 1 CSUMJ = CSUMJ + ( CONJG( A( I, J ) )*USCAL )* $ X( I ) 160 CONTINUE ELSE IF( J.LT.N ) THEN DO 170 I = J + 1, N CSUMJ = CSUMJ + ( CONJG( A( I, J ) )*USCAL )* $ X( I ) 170 CONTINUE END IF END IF * IF( USCAL.EQ.CMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = CONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 185 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**H *x = 0. * DO 180 I = 1, N X( I ) = ZERO 180 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 185 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = CLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 190 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL SSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of CLATRS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/clatsqr.f000066400000000000000000000171321522610125300264270ustar00rootroot00000000000000*> \brief \b CLATSQR * * 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 *> *> CLATSQR computes a blocked Tall-Skinny QR factorization of *> a complex M-by-N matrix A for M >= N: *> *> A = Q * ( R ), *> ( 0 ) *> *> where: *> *> Q is a M-by-M orthogonal matrix, stored on exit in an implicit *> form in the elements below the digonal of the array A and in *> the elemenst of the array T; *> *> R is an upper-triangular N-by-N matrix, stored on exit in *> the elements on and above the diagonal of the array A. *> *> 0 is a (M-N)-by-N zero matrix, and is not stored. *> *> \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.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- * November 2019 * * .. Scalar Arguments .. INTEGER 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/csteqr.f000066400000000000000000000365371522610125300262710ustar00rootroot00000000000000*> \brief \b CSTEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CSTEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CSTEQR computes all eigenvalues and, optionally, eigenvectors of a *> symmetric tridiagonal matrix using the implicit QL or QR method. *> The eigenvectors of a full or band complex Hermitian matrix can also *> be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this *> matrix to tridiagonal form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'V': Compute eigenvalues and eigenvectors of the original *> Hermitian matrix. On entry, Z must contain the *> unitary matrix used to reduce the original matrix *> to tridiagonal form. *> = 'I': Compute eigenvalues and eigenvectors of the *> tridiagonal matrix. Z is initialized to the identity *> matrix. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is REAL array, dimension (N) *> On entry, the diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is REAL array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', then Z contains the unitary *> matrix used in the reduction to tridiagonal form. *> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the *> orthonormal eigenvectors of the original Hermitian matrix, *> and if COMPZ = 'I', Z contains the orthonormal eigenvectors *> of the symmetric tridiagonal matrix. *> If COMPZ = '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 *> eigenvectors are desired, then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (max(1,2*N-2)) *> If COMPZ = 'N', then WORK 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: the algorithm has failed to find all the eigenvalues in *> a total of 30*N iterations; if INFO = i, then i *> elements of E have not converged to zero; on exit, D *> and E contain the elements of a symmetric tridiagonal *> matrix which is unitarily similar to the original *> matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, 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 COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. REAL D( * ), E( * ), WORK( * ) COMPLEX Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, $ THREE = 3.0E0 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), $ CONE = ( 1.0E0, 0.0E0 ) ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH, SLANST, SLAPY2 EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2 * .. * .. External Subroutines .. EXTERNAL CLASET, CLASR, CSWAP, SLAE2, SLAEV2, SLARTG, $ SLASCL, SLASRT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = CONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = SLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL CLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = SLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL SLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL CLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL CLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = SLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL SLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL CLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.EQ.NMAXIT ) THEN DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE RETURN END IF GO TO 10 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL SLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL CSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF RETURN * * End of CSTEQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctgevc.f000066400000000000000000000554501522610125300262360ustar00rootroot00000000000000*> \brief \b CTGEVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTGEVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * REAL RWORK( * ) * COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTGEVC computes some or all of the right and/or left eigenvectors of *> 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. *> If Q and Z are the unitary 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: * ========== * *> \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, *> specified 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 matrices S and P. N >= 0. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is COMPLEX array, dimension (LDS,N) *> The upper triangular matrix S from a generalized Schur *> factorization, as computed by CHGEQZ. *> \endverbatim *> *> \param[in] LDS *> \verbatim *> LDS is INTEGER *> The leading dimension of array S. LDS >= max(1,N). *> \endverbatim *> *> \param[in] P *> \verbatim *> P is COMPLEX array, dimension (LDP,N) *> The upper triangular matrix P from a generalized Schur *> factorization, as computed by CHGEQZ. P must have real *> diagonal elements. *> \endverbatim *> *> \param[in] LDP *> \verbatim *> LDP is INTEGER *> The leading dimension of array P. LDP >= 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 left Schur vectors returned by CHGEQZ). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of (S,P) 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 array VL. LDVL >= 1, and if *> SIDE = 'L' or 'l' or 'B' 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 Z *> of right Schur vectors returned by CHGEQZ). *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Z*X; *> if HOWMNY = 'S', the right eigenvectors of (S,P) 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 (2*N) *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is REAL array, dimension (2*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 complexGEcomputational * * ===================================================================== SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, 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 HOWMNY, SIDE INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) REAL RWORK( * ) COMPLEX P( LDP, * ), S( LDS, * ), 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 ) ) * .. * .. Local Scalars .. LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP, $ LSA, LSB INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC, $ J, JE, JR REAL ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG, $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA, $ SCALE, SMALL, TEMP, ULP, XMAX COMPLEX BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH COMPLEX CLADIV EXTERNAL LSAME, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CGEMV, SLABAD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL * .. * .. Statement Functions .. REAL ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) ) * .. * .. Executable Statements .. * * Decode and Test the input parameters * IF( LSAME( HOWMNY, 'A' ) ) THEN IHWMNY = 1 ILALL = .TRUE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. ELSE IHWMNY = -1 END IF * IF( LSAME( SIDE, 'R' ) ) THEN ISIDE = 1 COMPL = .FALSE. COMPR = .TRUE. ELSE IF( LSAME( SIDE, 'L' ) ) THEN ISIDE = 2 COMPL = .TRUE. COMPR = .FALSE. ELSE IF( LSAME( SIDE, 'B' ) ) THEN ISIDE = 3 COMPL = .TRUE. COMPR = .TRUE. ELSE ISIDE = -1 END IF * INFO = 0 IF( ISIDE.LT.0 ) THEN INFO = -1 ELSE IF( IHWMNY.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGEVC', -INFO ) RETURN END IF * * Count the number of eigenvectors * IF( .NOT.ILALL ) THEN IM = 0 DO 10 J = 1, N IF( SELECT( J ) ) $ IM = IM + 1 10 CONTINUE ELSE IM = N END IF * * Check diagonal of B * ILBBAD = .FALSE. DO 20 J = 1, N IF( AIMAG( P( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * IF( ILBBAD ) THEN INFO = -7 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN INFO = -12 ELSE IF( MM.LT.IM ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGEVC', -INFO ) RETURN END IF * * Quick return if possible * M = IM IF( N.EQ.0 ) $ RETURN * * Machine Constants * SAFMIN = SLAMCH( 'Safe minimum' ) BIG = ONE / SAFMIN CALL SLABAD( SAFMIN, BIG ) ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) SMALL = SAFMIN*N / ULP BIG = ONE / SMALL BIGNUM = ONE / ( SAFMIN*N ) * * Compute the 1-norm of each column of the strictly upper triangular * part of A and B to check for possible overflow in the triangular * solver. * ANORM = ABS1( S( 1, 1 ) ) BNORM = ABS1( P( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) 30 CONTINUE ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) BSCALE = ONE / MAX( BNORM, SAFMIN ) * * Left eigenvectors * IF( COMPL ) THEN IEIG = 0 * * Main loop over eigenvalues * DO 140 JE = 1, N IF( ILALL ) THEN ILCOMP = .TRUE. ELSE ILCOMP = SELECT( JE ) END IF IF( ILCOMP ) THEN IEIG = IEIG + 1 * IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * DO 50 JR = 1, N VL( JR, IEIG ) = CZERO 50 CONTINUE VL( IEIG, IEIG ) = CONE GO TO 140 END IF * * Non-singular eigenvalue: * Compute coefficients a and b in * H * y ( a A - b B ) = 0 * TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, $ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN ) SALPHA = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * * Scale to avoid underflow * LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. $ SMALL * SCALE = ONE IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), $ ABS1( BCOEFF ) ) ) ) IF( LSA ) THEN ACOEFF = ASCALE*( SCALE*SBETA ) ELSE ACOEFF = SCALE*ACOEFF END IF IF( LSB ) THEN BCOEFF = BSCALE*( SCALE*SALPHA ) ELSE BCOEFF = SCALE*BCOEFF END IF END IF * ACOEFA = ABS( ACOEFF ) BCOEFA = ABS1( BCOEFF ) XMAX = ONE DO 60 JR = 1, N WORK( JR ) = CZERO 60 CONTINUE WORK( JE ) = CONE DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * H * Triangular solve of (a A - b B) y = 0 * * H * (rowwise in (a A - b B) , or columnwise in a A - b B) * DO 100 J = JE + 1, N * * Compute * j-1 * SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * (Scale if necessary) * TEMP = ONE / XMAX IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM* $ TEMP ) THEN DO 70 JR = JE, J - 1 WORK( JR ) = TEMP*WORK( JR ) 70 CONTINUE XMAX = ONE END IF SUMA = CZERO SUMB = CZERO * DO 80 JR = JE, J - 1 SUMA = SUMA + CONJG( S( JR, J ) )*WORK( JR ) SUMB = SUMB + CONJG( P( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - CONJG( BCOEFF )*SUMB * * Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) * * with scaling and perturbation of the denominator * D = CONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = CMPLX( DMIN ) * IF( ABS1( D ).LT.ONE ) THEN IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN TEMP = ONE / ABS1( SUM ) DO 90 JR = JE, J - 1 WORK( JR ) = TEMP*WORK( JR ) 90 CONTINUE XMAX = TEMP*XMAX SUM = TEMP*SUM END IF END IF WORK( J ) = CLADIV( -SUM, D ) XMAX = MAX( XMAX, ABS1( WORK( J ) ) ) 100 CONTINUE * * Back transform eigenvector if HOWMNY='B'. * IF( ILBACK ) THEN CALL CGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL, $ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 ) ISRC = 2 IBEG = 1 ELSE ISRC = 1 IBEG = JE END IF * * Copy and scale eigenvector into column of VL * XMAX = ZERO DO 110 JR = IBEG, N XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) 110 CONTINUE * IF( XMAX.GT.SAFMIN ) THEN TEMP = ONE / XMAX DO 120 JR = IBEG, N VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) 120 CONTINUE ELSE IBEG = N + 1 END IF * DO 130 JR = 1, IBEG - 1 VL( JR, IEIG ) = CZERO 130 CONTINUE * END IF 140 CONTINUE END IF * * Right eigenvectors * IF( COMPR ) THEN IEIG = IM + 1 * * Main loop over eigenvalues * DO 250 JE = N, 1, -1 IF( ILALL ) THEN ILCOMP = .TRUE. ELSE ILCOMP = SELECT( JE ) END IF IF( ILCOMP ) THEN IEIG = IEIG - 1 * IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * DO 150 JR = 1, N VR( JR, IEIG ) = CZERO 150 CONTINUE VR( IEIG, IEIG ) = CONE GO TO 250 END IF * * Non-singular eigenvalue: * Compute coefficients a and b in * * ( a A - b B ) x = 0 * TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, $ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN ) SALPHA = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * * Scale to avoid underflow * LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. $ SMALL * SCALE = ONE IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), $ ABS1( BCOEFF ) ) ) ) IF( LSA ) THEN ACOEFF = ASCALE*( SCALE*SBETA ) ELSE ACOEFF = SCALE*ACOEFF END IF IF( LSB ) THEN BCOEFF = BSCALE*( SCALE*SALPHA ) ELSE BCOEFF = SCALE*BCOEFF END IF END IF * ACOEFA = ABS( ACOEFF ) BCOEFA = ABS1( BCOEFF ) XMAX = ONE DO 160 JR = 1, N WORK( JR ) = CZERO 160 CONTINUE WORK( JE ) = CONE DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * Triangular solve of (a A - b B) x = 0 (columnwise) * * WORK(1:j-1) contains sums w, * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * DO 210 J = JE - 1, 1, -1 * * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = CMPLX( DMIN ) * IF( ABS1( D ).LT.ONE ) THEN IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN TEMP = ONE / ABS1( WORK( J ) ) DO 180 JR = 1, JE WORK( JR ) = TEMP*WORK( JR ) 180 CONTINUE END IF END IF * WORK( J ) = CLADIV( -WORK( J ), D ) * IF( J.GT.1 ) THEN * * w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE. $ BIGNUM*TEMP ) THEN DO 190 JR = 1, JE WORK( JR ) = TEMP*WORK( JR ) 190 CONTINUE END IF END IF * CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - $ CB*P( JR, J ) 200 CONTINUE END IF 210 CONTINUE * * Back transform eigenvector if HOWMNY='B'. * IF( ILBACK ) THEN CALL CGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1, $ CZERO, WORK( N+1 ), 1 ) ISRC = 2 IEND = N ELSE ISRC = 1 IEND = JE END IF * * Copy and scale eigenvector into column of VR * XMAX = ZERO DO 220 JR = 1, IEND XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) 220 CONTINUE * IF( XMAX.GT.SAFMIN ) THEN TEMP = ONE / XMAX DO 230 JR = 1, IEND VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) 230 CONTINUE ELSE IEND = 0 END IF * DO 240 JR = IEND + 1, N VR( JR, IEIG ) = CZERO 240 CONTINUE * END IF 250 CONTINUE END IF * RETURN * * End of CTGEVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctgex2.f000066400000000000000000000262031522610125300261510ustar00rootroot00000000000000*> \brief \b CTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary equivalence transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTGEX2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) *> in an upper triangular matrix pair (A, B) by an unitary equivalence *> transformation. *> *> (A, B) must be in generalized Schur canonical form, that is, A and *> B are both upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H *> Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 arrays, dimensions (LDA,N) *> On entry, the matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \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 arrays, dimensions (LDB,N) *> On entry, the matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDZ,N) *> If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, *> the updated matrix Q. *> Not referenced if WANTQ = .FALSE.. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,N) *> If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, *> the updated matrix Z. *> Not referenced if WANTZ = .FALSE.. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index to the first block (A11, B11). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEauxiliary * *> \par Further Details: * ===================== *> *> In the current code both weak and strong stability tests are *> performed. The user can omit the strong stability test by changing *> the internal logical parameter WANDS to .FALSE.. See ref. [2] for *> details. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \n *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, Report UMINF-94.04, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, 1994. Also as LAPACK Working Note 87. To appear in *> Numerical Algorithms, 1996. *> * ===================================================================== SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 WANTQ, WANTZ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) REAL TWENTY PARAMETER ( TWENTY = 2.0E+1 ) INTEGER LDST PARAMETER ( LDST = 2 ) LOGICAL WANDS PARAMETER ( WANDS = .TRUE. ) * .. * .. Local Scalars .. LOGICAL STRONG, WEAK INTEGER I, M REAL CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM, $ THRESH, WS COMPLEX CDUM, F, G, SQ, SZ * .. * .. Local Arrays .. COMPLEX S( LDST, LDST ), T( LDST, LDST ), WORK( 8 ) * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL CLACPY, CLARTG, CLASSQ, CROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, REAL, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.1 ) $ RETURN * M = LDST WEAK = .FALSE. STRONG = .FALSE. * * Make a local copy of selected block in (A, B) * CALL CLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) CALL CLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) * * Compute the threshold for testing the acceptance of swapping. * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS SCALE = REAL( CZERO ) SUM = REAL( CONE ) CALL CLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL CLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M ) CALL CLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) SA = SCALE*SQRT( SUM ) * * THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * on 04/01/10. * "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by * Jim Demmel and Guillaume Revy. See forum post 1783. * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * * Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks * using Givens rotations and perform the swap tentatively. * F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) SA = ABS( S( 2, 2 ) ) SB = ABS( T( 2, 2 ) ) CALL CLARTG( G, F, CZ, SZ, CDUM ) SZ = -SZ CALL CROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, CONJG( SZ ) ) CALL CROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, CONJG( SZ ) ) IF( SA.GE.SB ) THEN CALL CLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM ) ELSE CALL CLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM ) END IF CALL CROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ ) CALL CROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ ) * * Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) * WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) WEAK = WS.LE.THRESH IF( .NOT.WEAK ) $ GO TO 20 * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL**H*S*QR, B-QL**H*T*QR)) <= O(EPS*F-norm((A, B))) * CALL CLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL CLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M ) CALL CROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -CONJG( SZ ) ) CALL CROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ, -CONJG( SZ ) ) CALL CROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ ) CALL CROT( 2, WORK( 5 ), 2, WORK( 6 ), 2, CQ, -SQ ) DO 10 I = 1, 2 WORK( I ) = WORK( I ) - A( J1+I-1, J1 ) WORK( I+2 ) = WORK( I+2 ) - A( J1+I-1, J1+1 ) WORK( I+4 ) = WORK( I+4 ) - B( J1+I-1, J1 ) WORK( I+6 ) = WORK( I+6 ) - B( J1+I-1, J1+1 ) 10 CONTINUE SCALE = REAL( CZERO ) SUM = REAL( CONE ) CALL CLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) SS = SCALE*SQRT( SUM ) STRONG = SS.LE.THRESH IF( .NOT.STRONG ) $ GO TO 20 END IF * * If the swap is accepted ("weakly" and "strongly"), apply the * equivalence transformations to the original matrix pair (A,B) * CALL CROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ, CONJG( SZ ) ) CALL CROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ, CONJG( SZ ) ) CALL CROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ, SQ ) CALL CROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, CQ, SQ ) * * Set N1 by N2 (2,1) blocks to 0 * A( J1+1, J1 ) = CZERO B( J1+1, J1 ) = CZERO * * Accumulate transformations into Q and Z if requested. * IF( WANTZ ) $ CALL CROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ, CONJG( SZ ) ) IF( WANTQ ) $ CALL CROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ, CONJG( SQ ) ) * * Exit with INFO = 0 if swap was successfully performed. * RETURN * * Exit with INFO = 1 if swap was rejected. * 20 CONTINUE INFO = 1 RETURN * * End of CTGEX2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctgexc.f000066400000000000000000000213221522610125300262270ustar00rootroot00000000000000*> \brief \b CTGEXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTGEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTGEXC reorders the generalized Schur decomposition of a complex *> matrix pair (A,B), using an unitary equivalence transformation *> (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with *> row index IFST is moved to row ILST. *> *> (A, B) must be in generalized Schur canonical form, that is, A and *> B are both upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H *> Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 upper triangular matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \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 upper triangular matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDZ,N) *> On entry, if WANTQ = .TRUE., the unitary matrix Q. *> On exit, the updated matrix Q. *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., the unitary matrix Z. *> On exit, the updated matrix Z. *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> Specify the reordering of the diagonal blocks of (A, B). *> The block with row index IFST is moved to row ILST, by a *> sequence of swapping between adjacent blocks. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit. *> <0: if INFO = -i, the i-th argument had an illegal value. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. (A, B) may have been partially reordered, *> and ILST points to the first row of the current *> position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexGEcomputational * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \n *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, Report *> UMINF - 94.04, Department of Computing Science, Umea University, *> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. *> To appear in Numerical Algorithms, 1996. *> \n *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> * ===================================================================== SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, 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 .. LOGICAL WANTQ, WANTZ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER HERE * .. * .. External Subroutines .. EXTERNAL CTGEX2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input arguments. INFO = 0 IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -12 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGEXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * HERE = IFST * 10 CONTINUE * * Swap with next one below * CALL CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, $ HERE, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 IF( HERE.LT.ILST ) $ GO TO 10 HERE = HERE - 1 ELSE HERE = IFST - 1 * 20 CONTINUE * * Swap with next one above * CALL CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, $ HERE, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 IF( HERE.GE.ILST ) $ GO TO 20 HERE = HERE + 1 END IF ILST = HERE RETURN * * End of CTGEXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctgsen.f000066400000000000000000000640231522610125300262420ustar00rootroot00000000000000*> \brief \b CTGSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTGSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ M, N * REAL PL, PR * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * REAL DIF( * ) * COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTGSEN reorders the generalized Schur decomposition of a complex *> matrix pair (A, B) (in terms of an unitary equivalence trans- *> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues *> appears in the leading diagonal blocks of the pair (A,B). The leading *> columns of Q and Z form unitary bases of the corresponding left and *> right eigenspaces (deflating subspaces). (A, B) must be in *> generalized Schur canonical form, that is, A and B are both upper *> triangular. *> *> CTGSEN also computes the generalized eigenvalues *> *> w(j)= ALPHA(j) / BETA(j) *> *> of the reordered matrix pair (A, B). *> *> Optionally, the routine computes estimates of reciprocal condition *> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), *> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) *> between the matrix pairs (A11, B11) and (A22,B22) that correspond to *> the selected cluster and the eigenvalues outside the cluster, resp., *> and norms of "projections" onto left and right eigenspaces w.r.t. *> the selected cluster in the (1,1)-block. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is integer *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (PL and PR) or the deflating subspaces *> (Difu and Difl): *> =0: Only reorder w.r.t. SELECT. No extras. *> =1: Reciprocal of norms of "projections" onto left and right *> eigenspaces w.r.t. the selected cluster (PL and PR). *> =2: Upper bounds on Difu and Difl. F-norm-based estimate *> (DIF(1:2)). *> =3: Estimate of Difu and Difl. 1-norm-based estimate *> (DIF(1:2)). *> About 5 times as expensive as IJOB = 2. *> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic *> version to get it all. *> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) *> \endverbatim *> *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select an eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. *> \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 upper triangular matrix A, in generalized *> Schur canonical form. *> On exit, A is overwritten by the reordered matrix A. *> \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 upper triangular matrix B, in generalized *> Schur canonical form. *> On exit, B is overwritten by the reordered matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX array, dimension (N) *> *> The diagonal elements of A and B, respectively, *> when the pair (A,B) has been reduced to generalized Schur *> form. ALPHA(i)/BETA(i) i=1,...,N are the generalized *> eigenvalues. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. *> On exit, Q has been postmultiplied by the left unitary *> transformation matrix which reorder (A, B); The leading M *> columns of Q form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. *> On exit, Z has been postmultiplied by the left unitary *> transformation matrix which reorder (A, B); The leading M *> columns of Z form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified pair of left and right *> eigenspaces, (deflating subspaces) 0 <= M <= N. *> \endverbatim *> *> \param[out] PL *> \verbatim *> PL is REAL *> \endverbatim *> *> \param[out] PR *> \verbatim *> PR is REAL *> *> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the *> reciprocal of the norm of "projections" onto left and right *> eigenspace with respect to the selected cluster. *> 0 < PL, PR <= 1. *> If M = 0 or M = N, PL = PR = 1. *> If IJOB = 0, 2 or 3 PL, PR are not referenced. *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is REAL array, dimension (2). *> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. *> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on *> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based *> estimates of Difu and Difl, computed using reversed *> communication with CLACN2. *> If M = 0 or N, DIF(1:2) = F-norm([A, B]). *> If IJOB = 0 or 1, DIF is not referenced. *> \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. LWORK >= 1 *> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) *> If IJOB = 3 or 5, LWORK >= 4*M*(N-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] 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. LIWORK >= 1. *> If IJOB = 1, 2 or 4, LIWORK >= N+2; *> If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); *> *> 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. *> =1: Reordering of (A, B) failed because the transformed *> matrix pair (A, B) would be too far from generalized *> Schur form; the problem is very ill-conditioned. *> (A, B) may have been partially reordered. *> If requested, 0 is returned in DIF(*), PL and PR. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complexOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> CTGSEN first collects the selected eigenvalues by computing unitary *> U and W that move them to the top left corner of (A, B). In other *> words, the selected eigenvalues are the eigenvalues of (A11, B11) in *> *> U**H*(A, B)*W = (A11 A12) (B11 B12) n1 *> ( 0 A22),( 0 B22) n2 *> n1 n2 n1 n2 *> *> where N = n1+n2 and U**H means the conjugate transpose of U. The first *> n1 columns of U and W span the specified pair of left and right *> eigenspaces (deflating subspaces) of (A, B). *> *> If (A, B) has been obtained from the generalized real Schur *> decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the *> reordered generalized Schur form of (C, D) is given by *> *> (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H, *> *> and the first n1 columns of Q*U and Z*W span the corresponding *> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). *> *> Note that if the selected eigenvalue is sufficiently ill-conditioned, *> then its value may differ significantly from its value before *> reordering. *> *> The reciprocal condition numbers of the left and right eigenspaces *> spanned by the first n1 columns of U and W (or Q*U and Z*W) may *> be returned in DIF(1:2), corresponding to Difu and Difl, resp. *> *> The Difu and Difl are defined as: *> *> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) *> and *> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], *> *> where sigma-min(Zu) is the smallest singular value of the *> (2*n1*n2)-by-(2*n1*n2) matrix *> *> Zu = [ kron(In2, A11) -kron(A22**H, In1) ] *> [ kron(In2, B11) -kron(B22**H, In1) ]. *> *> Here, Inx is the identity matrix of size nx and A22**H is the *> conjuguate transpose of A22. kron(X, Y) is the Kronecker product between *> the matrices X and Y. *> *> When DIF(2) is small, small changes in (A, B) can cause large changes *> in the deflating subspace. An approximate (asymptotic) bound on the *> maximum angular error in the computed deflating subspaces is *> *> EPS * norm((A, B)) / DIF(2), *> *> where EPS is the machine precision. *> *> The reciprocal norm of the projectors on the left and right *> eigenspaces associated with (A11, B11) may be returned in PL and PR. *> They are computed as follows. First we compute L and R so that *> P*(A, B)*Q is block diagonal, where *> *> P = ( I -L ) n1 Q = ( I R ) n1 *> ( 0 I ) n2 and ( 0 I ) n2 *> n1 n2 n1 n2 *> *> and (L, R) is the solution to the generalized Sylvester equation *> *> A11*R - L*A22 = -A12 *> B11*R - L*B22 = -B12 *> *> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). *> An approximate (asymptotic) bound on the average absolute error of *> the selected eigenvalues is *> *> EPS * norm((A, B)) / PL. *> *> There are also global error bounds which valid for perturbations up *> to a certain restriction: A lower bound (x) on the smallest *> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and *> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), *> (i.e. (A + E, B + F), is *> *> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). *> *> An approximate bound on x can be computed from DIF(1:2), PL and PR. *> *> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed *> (L', R') and unperturbed (L, R) left and right deflating subspaces *> associated with the selected cluster in the (1,1)-blocks can be *> bounded as *> *> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) *> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) *> *> See LAPACK User's Guide section 4.11 or the following references *> for more information. *> *> Note that if the default method for computing the Frobenius-norm- *> based estimate DIF is not wanted (see CLATDF), then the parameter *> IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF *> (IJOB = 2 will be used)). See CTGSYL for more details. *> \endverbatim * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \n *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, Report *> UMINF - 94.04, Department of Computing Science, Umea University, *> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. *> To appear in Numerical Algorithms, 1996. *> \n *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> * ===================================================================== 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.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 .. LOGICAL WANTQ, WANTZ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, $ M, N REAL PL, PR * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) REAL DIF( * ) COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IDIFJB PARAMETER ( IDIFJB = 3 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2, $ N1, N2 REAL DSCALE, DSUM, RDSCAL, SAFMIN COMPLEX TEMP1, TEMP2 * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. REAL SLAMCH EXTERNAL CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC, CTGSYL, $ SLAMCH, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, CONJG, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -13 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGSEN', -INFO ) RETURN END IF * IERR = 0 * WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 WANTD = WANTD1 .OR. WANTD2 * * Set M to the dimension of the specified pair of deflating * 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 ) IF( K.LT.N ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE IF( SELECT( N ) ) $ 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) ) LIWMIN = MAX( 1, N+2 ) ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN LWMIN = MAX( 1, 4*M*(N-M) ) LIWMIN = MAX( 1, 2*M*(N-M), N+2 ) ELSE LWMIN = 1 LIWMIN = 1 END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -21 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -23 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTP ) THEN PL = ONE PR = ONE END IF IF( WANTD ) THEN DSCALE = ZERO DSUM = ONE DO 20 I = 1, N CALL CLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) CALL CLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 20 CONTINUE DIF( 1 ) = DSCALE*SQRT( DSUM ) DIF( 2 ) = DIF( 1 ) END IF GO TO 70 END IF * * Get machine constant * SAFMIN = SLAMCH( 'S' ) * * Collect the selected blocks at the top-left corner of (A, B). * KS = 0 DO 30 K = 1, N SWAP = SELECT( K ) IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. Compute unitary Q * and Z that will swap adjacent diagonal blocks in (A, B). * IF( K.NE.KS ) $ CALL CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, K, KS, IERR ) * IF( IERR.GT.0 ) THEN * * Swap is rejected: exit. * INFO = 1 IF( WANTP ) THEN PL = ZERO PR = ZERO END IF IF( WANTD ) THEN DIF( 1 ) = ZERO DIF( 2 ) = ZERO END IF GO TO 70 END IF END IF 30 CONTINUE IF( WANTP ) THEN * * Solve generalized Sylvester equation for R and L: * A11 * R - L * A22 = A12 * B11 * R - L * B22 = B12 * N1 = M N2 = N - M I = N1 + 1 CALL CLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) CALL CLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), $ N1 ) IJB = 0 CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Estimate the reciprocal of norms of "projections" onto * left and right eigenspaces * RDSCAL = ZERO DSUM = ONE CALL CLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) PL = RDSCAL*SQRT( DSUM ) IF( PL.EQ.ZERO ) THEN PL = ONE ELSE PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) END IF RDSCAL = ZERO DSUM = ONE CALL CLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) PR = RDSCAL*SQRT( DSUM ) IF( PR.EQ.ZERO ) THEN PR = ONE ELSE PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) END IF END IF IF( WANTD ) THEN * * Compute estimates Difu and Difl. * IF( WANTD1 ) THEN N1 = M N2 = N - M I = N1 + 1 IJB = IDIFJB * * Frobenius norm-based Difu estimate. * CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), $ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Frobenius norm-based Difl estimate. * CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), $ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) ELSE * * Compute 1-norm-based estimates of Difu and Difl using * reversed communication with CLACN2. In each step a * generalized Sylvester equation or a transposed variant * is solved. * KASE = 0 N1 = M N2 = N - M I = N1 + 1 IJB = 0 MN2 = 2*N1*N2 * * 1-norm-based estimate of Difu. * 40 CONTINUE CALL CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation * CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL CTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 40 END IF DIF( 1 ) = DSCALE / DIF( 1 ) * * 1-norm-based estimate of Difl. * 50 CONTINUE CALL CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation * CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL CTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 50 END IF DIF( 2 ) = DSCALE / DIF( 2 ) END IF END IF * * If B(K,K) is complex, make it real and positive (normalization * of the generalized Schur form) and Store the generalized * eigenvalues of reordered pair (A, B) * DO 60 K = 1, N DSCALE = ABS( B( K, K ) ) IF( DSCALE.GT.SAFMIN ) THEN TEMP1 = CONJG( B( K, K ) / DSCALE ) TEMP2 = B( K, K ) / DSCALE B( K, K ) = DSCALE CALL CSCAL( N-K, TEMP1, B( K, K+1 ), LDB ) CALL CSCAL( N-K+1, TEMP1, A( K, K ), LDA ) IF( WANTQ ) $ CALL CSCAL( N, TEMP2, Q( 1, K ), 1 ) ELSE B( K, K ) = CMPLX( ZERO, ZERO ) END IF * ALPHA( K ) = A( K, K ) BETA( K ) = B( K, K ) * 60 CONTINUE * 70 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of CTGSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctgsy2.f000066400000000000000000000354031522610125300261720ustar00rootroot00000000000000*> \brief \b CTGSY2 solves the generalized Sylvester equation (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTGSY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * REAL RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTGSY2 solves the generalized Sylvester equation *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, *> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, *> N-by-N and M-by-N, respectively. A, B, D and E are upper triangular *> (i.e., (A,D) and (B,E) in generalized Schur form). *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output *> scaling factor chosen to avoid overflow. *> *> In matrix notation solving equation (1) corresponds to solve *> Zx = scale * b, where Z is defined as *> *> Z = [ kron(In, A) -kron(B**H, Im) ] (2) *> [ kron(In, D) -kron(E**H, Im) ], *> *> Ik is the identity matrix of size k and X**H is the transpose of X. *> kron(X, Y) is the Kronecker product between the matrices X and Y. *> *> If TRANS = 'C', y in the conjugate transposed system Z**H*y = scale*b *> is solved for, which is equivalent to solve for R and L in *> *> A**H * R + D**H * L = scale * C (3) *> R * B**H + L * E**H = scale * -F *> *> This case is used to compute an estimate of Dif[(A, D), (B, E)] = *> = sigma_min(Z) using reverse communicaton with CLACON. *> *> CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL *> of an upper bound on the separation between to matrix pairs. Then *> the input (A, D), (B, E) are sub-pencils of two matrix pairs in *> CTGSYL. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T': solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (look ahead strategy is used). *> =2: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (SGECON on sub-systems is used.) *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the order of A and D, and the row *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of B and E, and the column *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA, M) *> On entry, A contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the matrix A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX array, dimension (LDB, N) *> On entry, B contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is COMPLEX array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1). *> On exit, if IJOB = 0, C has been overwritten by the solution *> R. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the matrix C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is COMPLEX array, dimension (LDD, M) *> On entry, D contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the matrix D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is COMPLEX array, dimension (LDE, N) *> On entry, E contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the matrix E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is COMPLEX array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1). *> On exit, if IJOB = 0, F has been overwritten by the solution *> L. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the matrix F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions *> R and L (C and F on entry) will hold the solutions to a *> slightly perturbed system but the input matrices A, B, D and *> E have not been changed. If SCALE = 0, R and L will hold the *> solutions to the homogeneous system with C = F = 0. *> Normally, SCALE = 1. *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is REAL *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by CTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when CTGSY2 is called by *> CTGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is REAL *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when CTGSY2 is called by *> CTGSYL. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, if INFO is set to *> =0: Successful exit *> <0: If INFO = -i, input argument number i is illegal. *> >0: The matrix pairs (A, D) and (B, E) have common or very *> close eigenvalues. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexSYauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N REAL RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE INTEGER LDZ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, LDZ = 2 ) * .. * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, IERR, J, K REAL SCALOC COMPLEX ALPHA * .. * .. Local Arrays .. INTEGER IPIV( LDZ ), JPIV( LDZ ) COMPLEX RHS( LDZ ), Z( LDZ, LDZ ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CAXPY, CGESC2, CGETC2, CSCAL, CLATDF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, CONJG, MAX * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 IERR = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGSY2', -INFO ) RETURN END IF * IF( NOTRAN ) THEN * * Solve (I, J) - system * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = M, M - 1, ..., 1; J = 1, 2, ..., N * SCALE = ONE SCALOC = ONE DO 30 J = 1, N DO 20 I = M, 1, -1 * * Build 2 by 2 system * Z( 1, 1 ) = A( I, I ) Z( 2, 1 ) = D( I, I ) Z( 1, 2 ) = -B( J, J ) Z( 2, 2 ) = -E( J, J ) * * Set up right hand side(s) * RHS( 1 ) = C( I, J ) RHS( 2 ) = F( I, J ) * * Solve Z * x = RHS * CALL CGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL CGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 10 K = 1, N CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL CLATDF( IJOB, LDZ, Z, LDZ, RHS, RDSUM, RDSCAL, $ IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( I, J ) = RHS( 1 ) F( I, J ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining equation. * IF( I.GT.1 ) THEN ALPHA = -RHS( 1 ) CALL CAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ), 1 ) CALL CAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ), 1 ) END IF IF( J.LT.N ) THEN CALL CAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB, $ C( I, J+1 ), LDC ) CALL CAXPY( N-J, RHS( 2 ), E( J, J+1 ), LDE, $ F( I, J+1 ), LDF ) END IF * 20 CONTINUE 30 CONTINUE ELSE * * Solve transposed (I, J) - system: * A(I, I)**H * R(I, J) + D(I, I)**H * L(J, J) = C(I, J) * R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1, 2, ..., M, J = N, N - 1, ..., 1 * SCALE = ONE SCALOC = ONE DO 80 I = 1, M DO 70 J = N, 1, -1 * * Build 2 by 2 system Z**H * Z( 1, 1 ) = CONJG( A( I, I ) ) Z( 2, 1 ) = -CONJG( B( J, J ) ) Z( 1, 2 ) = CONJG( D( I, I ) ) Z( 2, 2 ) = -CONJG( E( J, J ) ) * * * Set up right hand side(s) * RHS( 1 ) = C( I, J ) RHS( 2 ) = F( I, J ) * * Solve Z**H * x = RHS * CALL CGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR CALL CGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 40 K = 1, N CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( I, J ) = RHS( 1 ) F( I, J ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining equation. * DO 50 K = 1, J - 1 F( I, K ) = F( I, K ) + RHS( 1 )*CONJG( B( K, J ) ) + $ RHS( 2 )*CONJG( E( K, J ) ) 50 CONTINUE DO 60 K = I + 1, M C( K, J ) = C( K, J ) - CONJG( A( I, K ) )*RHS( 1 ) - $ CONJG( D( I, K ) )*RHS( 2 ) 60 CONTINUE * 70 CONTINUE 80 CONTINUE END IF RETURN * * End of CTGSY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctgsyl.f000066400000000000000000000562111522610125300262640ustar00rootroot00000000000000*> \brief \b CTGSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTGSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ LWORK, M, N * REAL DIF, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTGSYL solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> where R and L are unknown m-by-n matrices, (A, D), (B, E) and *> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, *> respectively, with complex entries. A, B, D and E are upper *> triangular (i.e., (A,D) and (B,E) in generalized Schur form). *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 *> is an output scaling factor chosen to avoid overflow. *> *> In matrix notation (1) is equivalent to solve Zx = scale*b, where Z *> is defined as *> *> Z = [ kron(In, A) -kron(B**H, Im) ] (2) *> [ kron(In, D) -kron(E**H, Im) ], *> *> Here Ix is the identity matrix of size x and X**H is the conjugate *> transpose of X. Kron(X, Y) is the Kronecker product between the *> matrices X and Y. *> *> If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b *> is solved for, which is equivalent to solve for R and L in *> *> A**H * R + D**H * L = scale * C (3) *> R * B**H + L * E**H = scale * -F *> *> This case (TRANS = 'C') is used to compute an one-norm-based estimate *> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) *> and (B,E), using CLACON. *> *> If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of *> Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the *> reciprocal of the smallest singular value of Z. *> *> This is a level-3 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': solve the generalized sylvester equation (1). *> = 'C': solve the "conjugate transposed" system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: The functionality of 0 and 3. *> =2: The functionality of 0 and 4. *> =3: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (look ahead strategy is used). *> =4: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (CGECON on sub-systems is used). *> Not referenced if TRANS = 'C'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrices A and D, and the row dimension of *> the matrices C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices B and E, and the column dimension *> of the matrices C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA, M) *> The upper triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX array, dimension (LDB, N) *> The upper triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is COMPLEX array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, C has been overwritten by *> the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is COMPLEX array, dimension (LDD, M) *> The upper triangular matrix D. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the array D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is COMPLEX array, dimension (LDE, N) *> The upper triangular matrix E. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the array E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is COMPLEX array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, F has been overwritten by *> the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is REAL *> On exit DIF is the reciprocal of a lower bound of the *> reciprocal of the Dif-function, i.e. DIF is an upper bound of *> Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2). *> IF IJOB = 0 or TRANS = 'C', DIF is not referenced. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit SCALE is the scaling factor in (1) or (3). *> If 0 < SCALE < 1, C and F hold the solutions R and L, resp., *> to a slightly perturbed system but the input matrices A, B, *> D and E have not been changed. If SCALE = 0, R and L will *> hold the solutions to the homogenious system with C = F = 0. *> \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. LWORK > = 1. *> If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*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] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+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: (A, D) and (B, E) have common or very close *> eigenvalues. *> \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: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, *> No 1, 1996. *> \n *> [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester *> Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. *> Appl., 15(4):1045-1060, 1994. *> \n *> [3] B. Kagstrom and L. Westin, Generalized Schur Methods with *> Condition Estimators for Solving the Generalized Sylvester *> Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, *> July 1989, pp 745-751. *> * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, $ LWORK, M, N REAL DIF, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ), $ WORK( * ) * .. * * ===================================================================== * Replaced various illegal calls to CCOPY by calls to CLASET. * Sven Hammarling, 1/5/02. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) COMPLEX CZERO PARAMETER ( CZERO = (0.0E+0, 0.0E+0) ) * .. * .. Local Scalars .. LOGICAL LQUERY, NOTRAN INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, $ LINFO, LWMIN, MB, NB, P, PQ, Q REAL DSCALE, DSUM, SCALE2, SCALOC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL CGEMM, CLACPY, CLASET, CSCAL, CTGSY2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, REAL, SQRT * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF * IF( INFO.EQ.0 ) THEN IF( NOTRAN ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN LWMIN = MAX( 1, 2*M*N ) ELSE LWMIN = 1 END IF ELSE LWMIN = 1 END IF WORK( 1 ) = LWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGSYL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN SCALE = 1 IF( NOTRAN ) THEN IF( IJOB.NE.0 ) THEN DIF = 0 END IF END IF RETURN END IF * * Determine optimal block sizes MB and NB * MB = ILAENV( 2, 'CTGSYL', TRANS, M, N, -1, -1 ) NB = ILAENV( 5, 'CTGSYL', TRANS, M, N, -1, -1 ) * ISOLVE = 1 IFUNC = 0 IF( NOTRAN ) THEN IF( IJOB.GE.3 ) THEN IFUNC = IJOB - 2 CALL CLASET( 'F', M, N, CZERO, CZERO, C, LDC ) CALL CLASET( 'F', M, N, CZERO, CZERO, F, LDF ) ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN ISOLVE = 2 END IF END IF * IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) $ THEN * * Use unblocked Level 2 solver * DO 30 IROUND = 1, ISOLVE * SCALE = ONE DSCALE = ZERO DSUM = ONE PQ = M*N CALL CTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, $ INFO ) IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL CLACPY( 'F', M, N, C, LDC, WORK, M ) CALL CLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL CLASET( 'F', M, N, CZERO, CZERO, C, LDC ) CALL CLASET( 'F', M, N, CZERO, CZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL CLACPY( 'F', M, N, WORK, M, C, LDC ) CALL CLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 30 CONTINUE * RETURN * END IF * * Determine block structure of A * P = 0 I = 1 40 CONTINUE IF( I.GT.M ) $ GO TO 50 P = P + 1 IWORK( P ) = I I = I + MB IF( I.GE.M ) $ GO TO 50 GO TO 40 50 CONTINUE IWORK( P+1 ) = M + 1 IF( IWORK( P ).EQ.IWORK( P+1 ) ) $ P = P - 1 * * Determine block structure of B * Q = P + 1 J = 1 60 CONTINUE IF( J.GT.N ) $ GO TO 70 * Q = Q + 1 IWORK( Q ) = J J = J + NB IF( J.GE.N ) $ GO TO 70 GO TO 60 * 70 CONTINUE IWORK( Q+1 ) = N + 1 IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) $ Q = Q - 1 * IF( NOTRAN ) THEN DO 150 IROUND = 1, ISOLVE * * Solve (I, J) - subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1, ..., 1; J = 1, 2, ..., Q * PQ = 0 SCALE = ONE DSCALE = ZERO DSUM = ONE DO 130 J = P + 2, Q JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 120 I = P, 1, -1 IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 CALL CTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO PQ = PQ + MB*NB IF( SCALOC.NE.ONE ) THEN DO 80 K = 1, JS - 1 CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 80 CONTINUE DO 90 K = JS, JE CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ), $ C( 1, K ), 1 ) CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ), $ F( 1, K ), 1 ) 90 CONTINUE DO 100 K = JS, JE CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ), $ C( IE+1, K ), 1 ) CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ), $ F( IE+1, K ), 1 ) 100 CONTINUE DO 110 K = JE + 1, N CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I,J) and L(I,J) into remaining equation. * IF( I.GT.1 ) THEN CALL CGEMM( 'N', 'N', IS-1, NB, MB, $ CMPLX( -ONE, ZERO ), A( 1, IS ), LDA, $ C( IS, JS ), LDC, CMPLX( ONE, ZERO ), $ C( 1, JS ), LDC ) CALL CGEMM( 'N', 'N', IS-1, NB, MB, $ CMPLX( -ONE, ZERO ), D( 1, IS ), LDD, $ C( IS, JS ), LDC, CMPLX( ONE, ZERO ), $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL CGEMM( 'N', 'N', MB, N-JE, NB, $ CMPLX( ONE, ZERO ), F( IS, JS ), LDF, $ B( JS, JE+1 ), LDB, CMPLX( ONE, ZERO ), $ C( IS, JE+1 ), LDC ) CALL CGEMM( 'N', 'N', MB, N-JE, NB, $ CMPLX( ONE, ZERO ), F( IS, JS ), LDF, $ E( JS, JE+1 ), LDE, CMPLX( ONE, ZERO ), $ F( IS, JE+1 ), LDF ) END IF 120 CONTINUE 130 CONTINUE IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL CLACPY( 'F', M, N, C, LDC, WORK, M ) CALL CLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL CLASET( 'F', M, N, CZERO, CZERO, C, LDC ) CALL CLASET( 'F', M, N, CZERO, CZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL CLACPY( 'F', M, N, WORK, M, C, LDC ) CALL CLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 150 CONTINUE ELSE * * Solve transposed (I, J)-subsystem * A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J) * R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1,2,..., P; J = Q, Q-1,..., 1 * SCALE = ONE DO 210 I = 1, P IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 DO 200 J = Q, P + 2, -1 JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 CALL CTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO IF( SCALOC.NE.ONE ) THEN DO 160 K = 1, JS - 1 CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 160 CONTINUE DO 170 K = JS, JE CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 170 CONTINUE DO 180 K = JS, JE CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ), $ C( IE+1, K ), 1 ) CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ), $ F( IE+1, K ), 1 ) 180 CONTINUE DO 190 K = JE + 1, N CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I,J) and L(I,J) into remaining equation. * IF( J.GT.P+2 ) THEN CALL CGEMM( 'N', 'C', MB, JS-1, NB, $ CMPLX( ONE, ZERO ), C( IS, JS ), LDC, $ B( 1, JS ), LDB, CMPLX( ONE, ZERO ), $ F( IS, 1 ), LDF ) CALL CGEMM( 'N', 'C', MB, JS-1, NB, $ CMPLX( ONE, ZERO ), F( IS, JS ), LDF, $ E( 1, JS ), LDE, CMPLX( ONE, ZERO ), $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL CGEMM( 'C', 'N', M-IE, NB, MB, $ CMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA, $ C( IS, JS ), LDC, CMPLX( ONE, ZERO ), $ C( IE+1, JS ), LDC ) CALL CGEMM( 'C', 'N', M-IE, NB, MB, $ CMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD, $ F( IS, JS ), LDF, CMPLX( ONE, ZERO ), $ C( IE+1, JS ), LDC ) END IF 200 CONTINUE 210 CONTINUE END IF * WORK( 1 ) = LWMIN * RETURN * * End of CTGSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctplqt.f000066400000000000000000000163051522610125300262660ustar00rootroot00000000000000* 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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 lower trapezoidal. *> *> The lower trapezoidal matrix B2 consists of the first L columns of a *> M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> [ W ] = [ I ] [ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctplqt2.f000066400000000000000000000206611522610125300263500ustar00rootroot00000000000000* 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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ I ][ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctpmlqt.f000066400000000000000000000230561522610125300264440ustar00rootroot00000000000000* 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 *> *> CTPMLQT 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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**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. *> 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**H*C or C*Q or C*Q**H. 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 June 2017 * *> \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**H * 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**H. *> \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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctpmqrt.f000066400000000000000000000243201522610125300264450ustar00rootroot00000000000000*> \brief \b CTPMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTPMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CTPQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CTPQRT 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 CTPQRT, stored as a NB-by-K matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \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**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. *> 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**H*C or C*Q or C*Q**H. 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*NB if SIDE = 'L', or M*NB 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 complexOTHERcomputational * *> \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 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 = '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. *> *> 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**H * 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**H. *> \endverbatim *> * ===================================================================== SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, 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, NB, LDT * .. * .. Array Arguments .. COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), $ WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. 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 LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN LDVQ = MAX( 1, N ) 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( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) 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( 'CTPMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * DO I = 1, K, NB 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 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 IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB 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 CALL CTPRFB( 'L', 'N', '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. TRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 ELSE 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * END IF * RETURN * * End of CTPMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctpqrt.f000066400000000000000000000172371522610125300263010ustar00rootroot00000000000000*> \brief \b CTPQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTPQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 *> WY representation for Q. *> \endverbatim * * Arguments: * ========== * *> \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, and the order of the *> triangular matrix A. *> N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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 *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (NB*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 complexOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 number of blocks is B = ceiling(N/NB), where each *> 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 *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. *> \endverbatim *> * ===================================================================== SUBROUTINE CTPQRT( M, N, L, NB, 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, NB * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, LB, MB, IINFO * .. * .. External Subroutines .. EXTERNAL CTPQRT2, 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( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTPQRT', -INFO ) RETURN END IF * * Quick return if possible * 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 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF * 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, $ WORK, IB ) END IF END DO RETURN * * End of CTPQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctpqrt2.f000066400000000000000000000207271522610125300263610ustar00rootroot00000000000000*> \brief \b CTPQRT2 computes a QR 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 CTPQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \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, *> 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 upper 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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,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 complexOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**H *> *> where W**H is the conjugate transpose of W and T is the upper triangular *> factor of the block reflector. *> \endverbatim *> * ===================================================================== SUBROUTINE CTPQRT2( 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( ONE = (1.0,0.0), ZERO = (0.0,0.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, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTPQRT2', -INFO ) RETURN END IF * * 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) * P = M-L+MIN( L, I ) CALL CLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) ) IF( I.LT.N ) THEN * * W(1:N-I) := C(I:M,I+1:N)**H * C(I:M,I) [use W = T(:,N)] * 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, $ 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 )) 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, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO * DO I = 2, N * * T(1:I-1,I) := C(I:M,1:I-1)**H * (alpha * C(I:M,I)) * ALPHA = -T( I, 1 ) DO J = 1, I-1 T( J, I ) = ZERO END DO P = MIN( I-1, L ) MP = MIN( M-L+1, M ) NP = MIN( P+1, N ) * * Triangular part of B2 * DO J = 1, P T( J, I ) = ALPHA*B( M-L+J, I ) END DO CALL CTRMV( 'U', 'C', 'N', P, B( MP, 1 ), LDB, $ T( 1, I ), 1 ) * * Rectangular part of B2 * 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 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL CTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO * * End of CTPQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctprfb.f000066400000000000000000000626641522610125300262500ustar00rootroot00000000000000*> \brief \b CTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTPRFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * ), * $ 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 *> blocks A and B, either from the left or right. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**H from the Left *> = 'R': apply H or H**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'C': apply H**H (Conjugate transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columns *> = 'R': Rows *> \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 order of the matrix T, i.e. the number of elementary *> 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. *> K >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The pentagonal matrix V, which contains the elementary reflectors *> H(1), H(2), ..., H(K). See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is COMPLEX array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= K. *> \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 *> 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. *> 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 *> H*C or H**H*C or C*H or C*H**H. 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, dimension *> (LDWORK,N) if SIDE = 'L', *> (LDWORK,K) if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> 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. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Further Details: * ===================== *> *> \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, *> 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] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] *> [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 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. *> *> If DIRECT = 'F' and STOREV = 'C': V = [V1] *> [V2] *> - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) *> *> If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] *> *> - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'C': V = [V2] *> [V1] *> - 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. *> *> If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. *> *> If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. *> *> If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. *> \endverbatim *> * ===================================================================== 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.7.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 DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * * ========================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = (1.0,0.0), ZERO = (0.0,0.0) ) * .. * .. Local Scalars .. INTEGER I, J, MP, NP, KP LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CGEMM, CTRMM * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 .OR. L.LT.0 ) RETURN * IF( LSAME( STOREV, 'C' ) ) THEN COLUMN = .TRUE. ROW = .FALSE. ELSE IF ( LSAME( STOREV, 'R' ) ) THEN COLUMN = .FALSE. ROW = .TRUE. ELSE COLUMN = .FALSE. ROW = .FALSE. END IF * IF( LSAME( SIDE, 'L' ) ) THEN LEFT = .TRUE. RIGHT = .FALSE. ELSE IF( LSAME( SIDE, 'R' ) ) THEN LEFT = .FALSE. RIGHT = .TRUE. ELSE LEFT = .FALSE. RIGHT = .FALSE. END IF * IF( LSAME( DIRECT, 'F' ) ) THEN FORWARD = .TRUE. BACKWARD = .FALSE. ELSE IF( LSAME( DIRECT, 'B' ) ) THEN FORWARD = .FALSE. BACKWARD = .TRUE. ELSE FORWARD = .FALSE. BACKWARD = .FALSE. END IF * * --------------------------------------------------------------------------- * IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (M-by-K) * * Form H C or H**H C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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, $ ONE, WORK, LDWORK ) 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, $ 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, 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 ) CALL CTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (N-by-K) * * Form C H or C H**H where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - (A + B V) T or A = A - (A + B V) T**H * B = B - (A + B V) T V**H or B = B - (A + B V) T**H V**H * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V, LDV, ONE, WORK, LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL CGEMM( 'N', 'C', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL CGEMM( 'N', 'C', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, $ V( NP, KP ), LDV, ONE, B( 1, NP ), LDB ) CALL CTRMM( 'R', 'U', 'C', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (M-by-K) * [ I ] (K-by-K) * * Form H C or H**H C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO * 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, $ 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 ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * 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, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL CGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL CTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (N-by-K) * [ I ] (K-by-K) * * Form C H or C H**H where C = [ B A ] (B is M-by-N, A is M-by-K) * * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - (A + B V) T or A = A - (A + B V) T**H * B = B - (A + B V) T V**H or B = B - (A + B V) T**H V**H * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL CGEMM( 'N', 'C', M, N-L, K, -ONE, WORK, LDWORK, $ V( NP, 1 ), LDV, ONE, B( 1, NP ), LDB ) CALL CGEMM( 'N', 'C', M, L, K-L, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL CTRMM( 'R', 'L', 'C', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**H C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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', '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, $ ONE, WORK, LDWORK ) CALL CGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), 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, $ 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( '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, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL CTRMM( 'L', 'L', 'C', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**H where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - (A + B V**H) T or A = A - (A + B V**H) T**H * B = B - (A + B V**H) T V or B = B - (A + B V**H) T**H V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL CTRMM( 'R', 'L', 'C', 'N', M, L, ONE, V( 1, NP ), LDV, $ 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, $ V( KP, 1 ), 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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 ) CALL CTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**H C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO CALL CTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) CALL CGEMM( 'N', 'N', L, N, M-L, ONE, V( KP, MP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL CGEMM( 'N', 'N', K-L, N, M, ONE, V, LDV, B, LDB, $ ZERO, WORK, 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', '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( '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, $ WORK, LDWORK, ONE, B, LDB ) CALL CTRMM( 'L', 'U', 'C', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**H where C = [ B A ] (A is M-by-K, B is M-by-N) * * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - (A + B V**H) T or A = A - (A + B V**H) T**H * B = B - (A + B V**H) T V or B = B - (A + B V**H) T**H V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL CTRMM( 'R', 'U', 'C', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) 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 ) * 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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, $ V, LDV, ONE, B, LDB ) CALL CTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * END IF * RETURN * * End of CTPRFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctrevc.f000066400000000000000000000351231522610125300262440ustar00rootroot00000000000000*> \brief \b CTREVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTREVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * REAL RWORK( * ) * COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTREVC 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. *> \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 (2*N) *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is REAL 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 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 CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, 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 HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, 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 CMZERO, CMONE PARAMETER ( CMZERO = ( 0.0E+0, 0.0E+0 ), $ CMONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV INTEGER I, II, IS, J, K, KI REAL OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL COMPLEX CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ICAMAX REAL SCASUM, SLAMCH EXTERNAL LSAME, ICAMAX, SCASUM, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMV, CLATRS, CSSCAL, SLABAD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL * .. * .. 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 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 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * 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+N ) = 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. * 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 ) * WORK( 1 ) = CMONE * * Form right-hand side. * DO 40 K = 1, KI - 1 WORK( K ) = -T( K, KI ) 40 CONTINUE * * Solve the 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 ), SCALE, RWORK, $ INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL CCOPY( KI, WORK( 1 ), 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 ) = CMZERO 60 CONTINUE ELSE IF( KI.GT.1 ) $ CALL CGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), $ 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 ) END IF * * Set back the original diagonal elements of T. * DO 70 K = 1, KI - 1 T( K, K ) = WORK( K+N ) 70 CONTINUE * IS = IS - 1 80 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * 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 ) * WORK( N ) = CMONE * * Form right-hand side. * DO 90 K = KI + 1, N WORK( K ) = -CONJG( T( KI, K ) ) 90 CONTINUE * * Solve the 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 ), SCALE, RWORK, INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL CCOPY( N-KI+1, WORK( KI ), 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 ) = CMZERO 110 CONTINUE ELSE IF( KI.LT.N ) $ CALL CGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1 ), 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 ) END IF * * Set back the original diagonal elements of T. * DO 120 K = KI + 1, N T( K, K ) = WORK( K+N ) 120 CONTINUE * IS = IS + 1 130 CONTINUE END IF * RETURN * * End of CTREVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctrexc.f000066400000000000000000000145241522610125300262500ustar00rootroot00000000000000*> \brief \b CTREXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTREXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. * COMPLEX Q( LDQ, * ), T( LDT, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTREXC reorders the Schur factorization of a complex matrix *> A = Q*T*Q**H, so that the diagonal element of T with row index IFST *> is moved to row ILST. *> *> The Schur form T is reordered by a unitary similarity transformation *> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by *> postmultplying it with Z. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] N *> \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 *> \verbatim *> T is COMPLEX array, dimension (LDT,N) *> On entry, the upper triangular matrix T. *> On exit, the reordered upper triangular matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> unitary transformation matrix Z which reorders T. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1, and if *> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in] ILST *> \verbatim *> ILST is INTEGER *> *> Specify the reordering of the diagonal elements of T: *> The element with row index IFST is moved to row ILST by a *> sequence of transpositions between adjacent elements. *> 1 <= IFST <= N; 1 <= ILST <= 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 complexOTHERcomputational * * ===================================================================== SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, 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 COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. COMPLEX Q( LDQ, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL WANTQ INTEGER K, M1, M2, M3 REAL CS COMPLEX SN, T11, T22, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLARTG, CROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN 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 ).AND.( N.GT.0 )) THEN INFO = -7 ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Move the IFST-th diagonal element forward down the diagonal. * M1 = 0 M2 = -1 M3 = 1 ELSE * * Move the IFST-th diagonal element backward up the diagonal. * M1 = -1 M2 = 0 M3 = -1 END IF * DO 10 K = IFST + M1, ILST + M2, M3 * * Interchange the k-th and (k+1)-th diagonal elements. * T11 = T( K, K ) T22 = T( K+1, K+1 ) * * Determine the transformation to perform the interchange. * CALL CLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( K+2.LE.N ) $ CALL CROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, $ SN ) CALL CROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, CONJG( SN ) ) * T( K, K ) = T22 T( K+1, K+1 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL CROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, $ CONJG( SN ) ) END IF * 10 CONTINUE * RETURN * * End of CTREXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctrsen.f000066400000000000000000000330351522610125300262540ustar00rootroot00000000000000*> \brief \b CTRSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTRSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL S, SEP * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * COMPLEX Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTRSEN reorders the Schur factorization of a complex matrix *> A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in *> the leading positions on the diagonal of the upper triangular matrix *> T, and the leading columns of Q form an orthonormal basis of the *> corresponding right invariant subspace. *> *> Optionally the routine computes the reciprocal condition numbers of *> the cluster of eigenvalues and/or the invariant subspace. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (S) or the invariant subspace (SEP): *> = 'N': none; *> = 'E': for eigenvalues only (S); *> = 'V': for invariant subspace only (SEP); *> = 'B': for both eigenvalues and invariant subspace (S and *> SEP). *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. *> \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) *> On entry, the upper triangular matrix T. *> On exit, T is overwritten by the reordered matrix T, with the *> selected eigenvalues as the leading diagonal elements. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> unitary transformation matrix which reorders T; the leading M *> columns of Q form an orthonormal basis for the specified *> invariant subspace. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX array, dimension (N) *> The reordered eigenvalues of T, in the same order as they *> appear on the diagonal of T. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified invariant subspace. *> 0 <= M <= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is REAL *> If JOB = 'E' or 'B', S is a lower bound on the reciprocal *> condition number for the selected cluster of eigenvalues. *> S cannot underestimate the true reciprocal condition number *> by more than a factor of sqrt(N). If M = 0 or N, S = 1. *> If JOB = 'N' or 'V', S is not referenced. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is REAL *> If JOB = 'V' or 'B', SEP is the estimated reciprocal *> condition number of the specified invariant subspace. If *> M = 0 or N, SEP = norm(T). *> If JOB = 'N' or 'E', SEP is not referenced. *> \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 JOB = 'N', LWORK >= 1; *> if JOB = 'E', LWORK = max(1,M*(N-M)); *> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-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. * *> \date December 2016 * *> \ingroup complexOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> CTRSEN first collects the selected eigenvalues by computing a unitary *> transformation Z to move them to the top left corner of T. In other *> words, the selected eigenvalues are the eigenvalues of T11 in: *> *> Z**H * T * Z = ( T11 T12 ) n1 *> ( 0 T22 ) n2 *> n1 n2 *> *> where N = n1+n2. The first *> n1 columns of Z span the specified invariant subspace of T. *> *> If T has been obtained from the Schur factorization of a matrix *> A = Q*T*Q**H, then the reordered Schur factorization of A is given by *> A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the *> corresponding invariant subspace of A. *> *> The reciprocal condition number of the average of the eigenvalues of *> T11 may be returned in S. S lies between 0 (very badly conditioned) *> and 1 (very well conditioned). It is computed as follows. First we *> compute R so that *> *> P = ( I R ) n1 *> ( 0 0 ) n2 *> n1 n2 *> *> is the projector on the invariant subspace associated with T11. *> R is the solution of the Sylvester equation: *> *> T11*R - R*T22 = T12. *> *> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote *> the two-norm of M. Then S is computed as the lower bound *> *> (1 + F-norm(R)**2)**(-1/2) *> *> on the reciprocal of 2-norm(P), the true reciprocal condition number. *> S cannot underestimate 1 / 2-norm(P) by more than a factor of *> sqrt(N). *> *> An approximate error bound for the computed average of the *> eigenvalues of T11 is *> *> EPS * norm(T) / S *> *> where EPS is the machine precision. *> *> The reciprocal condition number of the right invariant subspace *> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. *> SEP is defined as the separation of T11 and T22: *> *> sep( T11, T22 ) = sigma-min( C ) *> *> where sigma-min(C) is the smallest singular value of the *> n1*n2-by-n1*n2 matrix *> *> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) *> *> I(m) is an m by m identity matrix, and kprod denotes the Kronecker *> product. We estimate sigma-min(C) by the reciprocal of an estimate of *> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) *> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). *> *> When SEP is small, small changes in T can cause large changes in *> the invariant subspace. An approximate bound on the maximum angular *> error in the computed right invariant subspace is *> *> EPS * norm(T) / SEP *> \endverbatim *> * ===================================================================== SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, 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 COMPQ, JOB INTEGER INFO, LDQ, LDT, LWORK, M, N REAL S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) COMPLEX Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN REAL EST, RNORM, SCALE * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) REAL RWORK( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL CLANGE EXTERNAL LSAME, CLANGE * .. * .. External Subroutines .. EXTERNAL CLACN2, CLACPY, CTREXC, CTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters. * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * * Set M to the number of selected eigenvalues. * M = 0 DO 10 K = 1, N IF( SELECT( K ) ) $ M = M + 1 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) * IF( WANTSP ) THEN LWMIN = MAX( 1, 2*NN ) ELSE IF( LSAME( JOB, 'N' ) ) THEN LWMIN = 1 ELSE IF( LSAME( JOB, 'E' ) ) THEN LWMIN = MAX( 1, NN ) END IF * IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = CLANGE( '1', N, N, T, LDT, RWORK ) GO TO 40 END IF * * Collect the selected eigenvalues at the top left corner of T. * KS = 0 DO 20 K = 1, N IF( SELECT( K ) ) THEN KS = KS + 1 * * Swap the K-th eigenvalue to position KS. * IF( K.NE.KS ) $ CALL CTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR ) END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve the Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL CLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL CTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = CLANGE( 'F', N1, N2, WORK, N1, RWORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL CLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL CTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11**H*R - R*T22**H = scale*X. * CALL CTRSYL( 'C', 'C', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Copy reordered eigenvalues to W. * DO 50 K = 1, N W( K ) = T( K, K ) 50 CONTINUE * WORK( 1 ) = LWMIN * RETURN * * End of CTRSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctrsyl.f000066400000000000000000000325251522610125300263010ustar00rootroot00000000000000*> \brief \b CTRSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTRSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL SCALE * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTRSYL solves the complex Sylvester matrix equation: *> *> op(A)*X + X*op(B) = scale*C or *> op(A)*X - X*op(B) = scale*C, *> *> where op(A) = A or A**H, and A and B are both upper triangular. A is *> M-by-M and B is N-by-N; the right hand side C and the solution X are *> M-by-N; and scale is an output scale factor, set <= 1 to avoid *> overflow in X. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANA *> \verbatim *> TRANA is CHARACTER*1 *> Specifies the option op(A): *> = 'N': op(A) = A (No transpose) *> = 'C': op(A) = A**H (Conjugate transpose) *> \endverbatim *> *> \param[in] TRANB *> \verbatim *> TRANB is CHARACTER*1 *> Specifies the option op(B): *> = 'N': op(B) = B (No transpose) *> = 'C': op(B) = B**H (Conjugate transpose) *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> Specifies the sign in the equation: *> = +1: solve op(A)*X + X*op(B) = scale*C *> = -1: solve op(A)*X - X*op(B) = scale*C *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrix A, and the number of rows in the *> matrices X and C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B, and the number of columns in the *> matrices X and C. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA,M) *> The upper triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX array, dimension (LDB,N) *> The upper triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is COMPLEX array, dimension (LDC,N) *> On entry, the M-by-N right hand side matrix C. *> On exit, C is overwritten by the solution matrix X. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M) *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> The scale factor, scale, set <= 1 to avoid overflow in X. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: A and B have common or very close eigenvalues; perturbed *> values were used to solve the equation (but the matrices *> A and B are unchanged). *> \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 CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, 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 TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N REAL SCALE * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER J, K, L REAL BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM COMPLEX A11, SUML, SUMR, VEC, X11 * .. * .. Local Arrays .. REAL DUM( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL CLANGE, SLAMCH COMPLEX CDOTC, CDOTU, CLADIV EXTERNAL LSAME, CLANGE, SLAMCH, CDOTC, CDOTU, CLADIV * .. * .. External Subroutines .. EXTERNAL CSSCAL, SLABAD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRSYL', -INFO ) RETURN END IF * * Quick return if possible * SCALE = ONE IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*REAL( M*N ) / EPS BIGNUM = ONE / SMLNUM SMIN = MAX( SMLNUM, EPS*CLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*CLANGE( 'M', N, N, B, LDB, DUM ) ) SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * DO 30 L = 1, N DO 20 K = M, 1, -1 * SUML = CDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = CDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = A( K, K ) + SGN*B( L, L ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 20 CONTINUE 30 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A**H *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * DO 60 L = 1, N DO 50 K = 1, M * SUML = CDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = CDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = CONJG( A( K, K ) ) + SGN*B( L, L ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 50 CONTINUE 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A**H*X + ISGN*X*B**H = C. * * The (K,L)th block of X is determined starting from * upper-right corner column by column by * * A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L) * * Where * K-1 * R(K,L) = SUM [A**H(I,K)*X(I,L)] + * I=1 * N * ISGN*SUM [X(K,J)*B**H(L,J)]. * J=L+1 * DO 90 L = N, 1, -1 DO 80 K = 1, M * SUML = CDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = CDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*CONJG( SUMR ) ) * SCALOC = ONE A11 = CONJG( A( K, K )+SGN*B( L, L ) ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 80 CONTINUE 90 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B**H = C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)] * I=K+1 J=L+1 * DO 120 L = N, 1, -1 DO 110 K = M, 1, -1 * SUML = CDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = CDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*CONJG( SUMR ) ) * SCALOC = ONE A11 = A( K, K ) + SGN*CONJG( B( L, L ) ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 110 CONTINUE 120 CONTINUE * END IF * RETURN * * End of CTRSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ctrti2.f000066400000000000000000000134321522610125300261640ustar00rootroot00000000000000*> \brief \b CTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CTRTI2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CTRTI2 computes the inverse of a complex upper or lower triangular *> matrix. *> *> This is the Level 2 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit 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 triangular matrix A. If UPLO = 'U', the *> leading n by n upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. If DIAG = 'U', the *> diagonal elements of A are also not referenced and are *> assumed to be 1. *> *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J COMPLEX AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CSCAL, CTRMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, '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.NE.0 ) THEN CALL XERBLA( 'CTRTI2', -INFO ) RETURN END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL CTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL CSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE * * Compute inverse of lower triangular matrix. * DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL CTRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL CSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF * RETURN * * End of CTRTI2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cung2r.f000066400000000000000000000120651522610125300261560ustar00rootroot00000000000000*> \brief \b CUNG2R * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNG2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CUNG2R generates an m by n complex matrix Q with orthonormal columns, *> which is defined as the first n columns of a product of k elementary *> reflectors of order m *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by CGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by CGEQRF in the first k columns of its array *> argument A. *> On exit, the m by n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGEQRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has 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 * * ===================================================================== SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, 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, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL CLARF, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL CSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of CUNG2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunghr.f000066400000000000000000000146741522610125300262540ustar00rootroot00000000000000*> \brief \b CUNGHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNGHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CUNGHR generates a complex unitary matrix Q which is defined as the *> product of IHI-ILO elementary reflectors of order N, as returned by *> CGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of CGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by CGEHRD. *> On exit, the N-by-N unitary matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGEHRD. *> \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. LWORK >= IHI-ILO. *> For optimum performance LWORK >= (IHI-ILO)*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 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL CUNGQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'CUNGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL CUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of CUNGHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cungqr.f000066400000000000000000000175751522610125300262700ustar00rootroot00000000000000*> \brief \b CUNGQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNGQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> CUNGQR generates an M-by-N complex matrix Q with orthonormal columns, *> which is defined as the first N columns of a product of K elementary *> reflectors of order M *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by CGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by CGEQRF in the first k columns of its array *> argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGEQRF. *> \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. LWORK >= max(1,N). *> For optimum performance LWORK >= 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 has 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 * * ===================================================================== SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, 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, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL CLARFB, CLARFT, CUNG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'CUNGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'CUNGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'CUNGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL CUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL CLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL CLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL CUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of CUNGQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cungtsqr.f000066400000000000000000000220541522610125300266230ustar00rootroot00000000000000*> \brief \b CUNGTSQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNGTSQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> * Definition: * =========== * * SUBROUTINE CUNGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, * $ INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) * .. * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal *> columns, which are the first N columns of a product of comlpex unitary *> matrices of order M which are returned by CLATSQR *> *> Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). *> *> See the documentation for CLATSQR. *> \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 used by DLATSQR to return *> arrays A and T. MB > N. *> (Note that if MB > M, then M is used instead of MB *> as the row block size). *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The column block size used by CLATSQR to return *> arrays A and T. NB >= 1. *> (Note that if NB > N, then N is used instead of NB *> as the column block size). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> *> On entry: *> *> The elements on and above the diagonal are not accessed. *> The elements below the diagonal represent the unit *> lower-trapezoidal blocked matrix V computed by CLATSQR *> that defines the input matrices Q_in(k) (ones on the *> diagonal are not stored) (same format as the output A *> below the diagonal in CLATSQR). *> *> On exit: *> *> The array A contains an M-by-N orthonormal matrix Q_out, *> i.e the columns of A are orthogonal unit vectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] T *> \verbatim *> T is COMPLEX array, *> dimension (LDT, N * NIRB) *> where NIRB = Number_of_input_row_blocks *> = MAX( 1, CEIL((M-N)/(MB-N)) ) *> Let NICB = Number_of_input_col_blocks *> = CEIL(N/NB) *> *> The upper-triangular block reflectors used to define the *> input matrices Q_in(k), k=(1:NIRB*NICB). The block *> reflectors are stored in compact form in NIRB block *> reflector sequences. Each of NIRB block reflector sequences *> is stored in a larger NB-by-N column block of T and consists *> of NICB smaller NB-by-NB upper-triangular column blocks. *> (same format as the output T in CLATSQR). *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= max(1,min(NB1,N)). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> (workspace) COMPLEX array, dimension (MAX(2,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> The dimension of the array WORK. LWORK >= (M+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. * *> \date November 2019 * *> \ingroup comlexOTHERcomputational * *> \par Contributors: * ================== *> *> \verbatim *> *> November 2019, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> *> \endverbatim * * ===================================================================== SUBROUTINE CUNGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, $ INFO ) IMPLICIT NONE * * -- LAPACK computational routine (version 3.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2019 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX CONE, CZERO PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER IINFO, LDC, LWORKOPT, LC, LW, NBLOCAL, J * .. * .. External Subroutines .. EXTERNAL CCOPY, CLAMTSQR, CLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * LQUERY = LWORK.EQ.-1 INFO = 0 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 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDT.LT.MAX( 1, MIN( NB, N ) ) ) THEN INFO = -8 ELSE * * Test the input LWORK for the dimension of the array WORK. * This workspace is used to store array C(LDC, N) and WORK(LWORK) * in the call to CLAMTSQR. See the documentation for CLAMTSQR. * IF( LWORK.LT.2 .AND. (.NOT.LQUERY) ) THEN INFO = -10 ELSE * * Set block size for column blocks * NBLOCAL = MIN( NB, N ) * * LWORK = -1, then set the size for the array C(LDC,N) * in CLAMTSQR call and set the optimal size of the work array * WORK(LWORK) in CLAMTSQR call. * LDC = M LC = LDC*N LW = N * NBLOCAL * LWORKOPT = LC+LW * IF( ( LWORK.LT.MAX( 1, LWORKOPT ) ).AND.(.NOT.LQUERY) ) THEN INFO = -10 END IF END IF * END IF * * Handle error in the input parameters and return workspace query. * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNGTSQR', -INFO ) RETURN ELSE IF ( LQUERY ) THEN WORK( 1 ) = CMPLX( LWORKOPT ) RETURN END IF * * Quick return if possible * IF( MIN( M, N ).EQ.0 ) THEN WORK( 1 ) = CMPLX( LWORKOPT ) RETURN END IF * * (1) Form explicitly the tall-skinny M-by-N left submatrix Q1_in * of M-by-M orthogonal matrix Q_in, which is implicitly stored in * the subdiagonal part of input array A and in the input array T. * Perform by the following operation using the routine CLAMTSQR. * * Q1_in = Q_in * ( I ), where I is a N-by-N identity matrix, * ( 0 ) 0 is a (M-N)-by-N zero matrix. * * (1a) Form M-by-N matrix in the array WORK(1:LDC*N) with ones * on the diagonal and zeros elsewhere. * CALL CLASET( 'F', M, N, CZERO, CONE, WORK, LDC ) * * (1b) On input, WORK(1:LDC*N) stores ( I ); * ( 0 ) * * On output, WORK(1:LDC*N) stores Q1_in. * CALL CLAMTSQR( 'L', 'N', M, N, N, MB, NBLOCAL, A, LDA, T, LDT, $ WORK, LDC, WORK( LC+1 ), LW, IINFO ) * * (2) Copy the result from the part of the work array (1:M,1:N) * with the leading dimension LDC that starts at WORK(1) into * the output array A(1:M,1:N) column-by-column. * DO J = 1, N CALL CCOPY( M, WORK( (J-1)*LDC + 1 ), 1, A( 1, J ), 1 ) END DO * WORK( 1 ) = CMPLX( LWORKOPT ) RETURN * * End of CUNGTSQR * ENDqrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunm2r.f000066400000000000000000000165321522610125300261670ustar00rootroot00000000000000*> \brief \b CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNM2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNM2R overwrites the general complex m-by-n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**H* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**H if SIDE = 'R' and TRANS = 'C', *> *> where Q is a complex unitary matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by CGEQRF. 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**H from the Left *> = 'R': apply Q or Q**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] A *> \verbatim *> A is COMPLEX array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRF in the first k columns of its array argument A. *> A is modified by the routine but restored on exit. *> \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] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGEQRF. *> \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**H*C or C*Q**H 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, dimension *> (N) if SIDE = 'L', *> (M) 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 complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)**H * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = CONJG( TAU( I ) ) END IF AII = A( I, I ) A( I, I ) = ONE CALL CLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, $ WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of CUNM2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunmbr.f000066400000000000000000000256611522610125300262520ustar00rootroot00000000000000*> \brief \b CUNMBR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNMBR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'C': Q**H * C C * Q**H *> *> If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': P * C C * P *> TRANS = 'C': P**H * C C * P**H *> *> Here Q and P**H are the unitary matrices determined by CGEBRD when *> reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q *> and P**H are defined as products of elementary reflectors H(i) and *> G(i) respectively. *> *> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the *> order of the unitary matrix Q or P**H that is applied. *> *> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: *> if nq >= k, Q = H(1) H(2) . . . H(k); *> if nq < k, Q = H(1) H(2) . . . H(nq-1). *> *> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: *> if k < nq, P = G(1) G(2) . . . G(k); *> if k >= nq, P = G(1) G(2) . . . G(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'Q': apply Q or Q**H; *> = 'P': apply P or P**H. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q, Q**H, P or P**H from the Left; *> = 'R': apply Q, Q**H, P or P**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q or P; *> = 'C': Conjugate transpose, apply Q**H or P**H. *> \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 *> If VECT = 'Q', the number of columns in the original *> matrix reduced by CGEBRD. *> If VECT = 'P', the number of rows in the original *> matrix reduced by CGEBRD. *> K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension *> (LDA,min(nq,K)) if VECT = 'Q' *> (LDA,nq) if VECT = 'P' *> The vectors which define the elementary reflectors H(i) and *> G(i), whose products determine the matrices Q and P, as *> returned by CGEBRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If VECT = 'Q', LDA >= max(1,nq); *> if VECT = 'P', LDA >= max(1,min(nq,K)). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (min(nq,K)) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i) or G(i) which determines Q or P, as returned *> by CGEBRD in the array argument TAUQ or TAUP. *> \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**H*C or C*Q**H or C*Q *> or P*C or P**H*C or C*P or C*P**H. *> \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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M); *> if N = 0 or M = 0, LWORK >= 1. *> For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', *> and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the *> optimal blocksize. (NB = 0 if M = 0 or N = 0.) *> *> 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 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, 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, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL CUNMLQ, CUNMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( M.EQ.0 .OR. N.EQ.0 ) THEN NW = 0 END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( K.LT.0 ) THEN INFO = -6 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) $ THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( NW.GT.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'CUNMLQ', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'CUNMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW*NB ) ELSE LWKOPT = 1 END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to CGEBRD with nq >= k * CALL CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to CGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL CUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to CGEBRD with nq > k * CALL CUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to CGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL CUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of CUNMBR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunmhr.f000066400000000000000000000203151522610125300262470ustar00rootroot00000000000000*> \brief \b CUNMHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNMHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNMHR overwrites the general complex 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 of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> IHI-ILO elementary reflectors, as returned by CGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of CGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and *> ILO = 1 and IHI = 0, if M = 0; *> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and *> ILO = 1 and IHI = 0, if N = 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension *> (LDA,M) if SIDE = 'L' *> (LDA,N) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by CGEHRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGEHRD. *> \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**H*C or C*Q**H 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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', 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 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL CUNMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LEFT = LSAME( SIDE, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) $ THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN INFO = -5 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, NH, N, NH, -1 ) ELSE NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M, NH, NH, -1 ) END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNMHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = NH NI = N I1 = ILO + 1 I2 = 1 ELSE MI = M NI = NH I1 = 1 I2 = ILO + 1 END IF * CALL CUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) * WORK( 1 ) = LWKOPT RETURN * * End of CUNMHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunml2.f000066400000000000000000000170301522610125300261530ustar00rootroot00000000000000*> \brief \b CUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNML2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNML2 overwrites the general complex m-by-n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**H* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**H if SIDE = 'R' and TRANS = 'C', *> *> where Q is a complex unitary matrix defined as the product of k *> elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H *> *> as returned by CGELQF. 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**H from the Left *> = 'R': apply Q or Q**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] A *> \verbatim *> A is COMPLEX array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGELQF in the first k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGELQF. *> \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**H*C or C*Q**H 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, dimension *> (N) if SIDE = 'L', *> (M) 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 complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLACGV, CLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNML2', -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 .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)**H * IF( NOTRAN ) THEN TAUI = CONJG( TAU( I ) ) ELSE TAUI = TAU( I ) END IF IF( I.LT.NQ ) $ CALL CLACGV( NQ-I, A( I, I+1 ), LDA ) AII = A( I, I ) A( I, I ) = ONE CALL CLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII IF( I.LT.NQ ) $ CALL CLACGV( NQ-I, A( I, I+1 ), LDA ) 10 CONTINUE RETURN * * End of CUNML2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunmlq.f000066400000000000000000000227701522610125300262610ustar00rootroot00000000000000*> \brief \b CUNMLQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNMLQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNMLQ overwrites the general complex 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 k *> elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H *> *> as returned by CGELQF. 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Conjugate transpose, apply Q**H. *> \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] A *> \verbatim *> A is COMPLEX array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGELQF 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. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGELQF. *> \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**H*C or C*Q**H 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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL CLARFB, CLARFT, CUNML2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 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 NB = MIN( NBMAX, ILAENV( 1, 'CUNMLQ', SIDE // TRANS, M, N, $ K, -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN RETURN END IF * * Determine the block size * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'CUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL CLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**H * CALL CLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, $ A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of CUNMLQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunmqr.f000066400000000000000000000222771522610125300262710ustar00rootroot00000000000000*> \brief \b CUNMQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNMQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNMQR overwrites the general complex 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 k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by CGEQRF. 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Conjugate transpose, apply Q**H. *> \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] A *> \verbatim *> A is COMPLEX array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRF 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] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGEQRF. *> \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**H*C or C*Q**H 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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL CLARFB, CLARFT, CUNM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'CUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'CUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL CLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**H * CALL CLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of CUNMQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/cunmr2.f000066400000000000000000000166211522610125300261660ustar00rootroot00000000000000*> \brief \b CUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNMR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> CUNMR2 overwrites the general complex m-by-n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**H* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**H if SIDE = 'R' and TRANS = 'C', *> *> where Q is a complex unitary matrix defined as the product of k *> elementary reflectors *> *> Q = H(1)**H H(2)**H . . . H(k)**H *> *> as returned by CGERQF. 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**H from the Left *> = 'R': apply Q or Q**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] A *> \verbatim *> A is COMPLEX array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGERQF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by CGERQF. *> \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**H*C or C*Q**H 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, dimension *> (N) if SIDE = 'L', *> (M) 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 complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ COMPLEX AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLACGV, CLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNMR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) or H(i)**H is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) or H(i)**H * IF( NOTRAN ) THEN TAUI = CONJG( TAU( I ) ) ELSE TAUI = TAU( I ) END IF CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA ) AII = A( I, NQ-K+I ) A( I, NQ-K+I ) = ONE CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK ) A( I, NQ-K+I ) = AII CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA ) 10 CONTINUE RETURN * * End of CUNMR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/daxpby.f000066400000000000000000000067131522610125300262500ustar00rootroot00000000000000*> \brief \b DAXPY * * =========== DOCUMENTATION =========== * * 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 * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DAXPY constant times a vector plus a vector. *> uses unrolled loops for increments equal to one. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> number of elements in input vector(s) *> \endverbatim *> *> \param[in] DA *> \verbatim *> DA is DOUBLE PRECISION *> On entry, DA specifies the scalar alpha. *> \endverbatim *> *> \param[in] DX *> \verbatim *> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> storage spacing between elements of DX *> \endverbatim *> *> \param[in,out] DY *> \verbatim *> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> storage spacing between elements of DY *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup double_blas_level1 * *> \par Further Details: * ===================== *> *> \verbatim *> *> jack dongarra, linpack, 3/11/78. *> modified 12/3/93, array(1) declarations changed to array(*) *> \endverbatim *> * ===================================================================== SUBROUTINE DAXPBY(N,DA,DX,INCX,DB,DY,INCY) * * -- Reference BLAS level1 routine (version 3.8.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. DOUBLE PRECISION DA, DB INTEGER INCX,INCY,N * .. * .. Array Arguments .. DOUBLE PRECISION DX(*),DY(*) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I,IX,IY,M,MP1 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. IF (N.LE.0) RETURN IF (DA.EQ.0.0d0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN * * code for both increments equal to 1 * * * clean-up loop * M = MOD(N,4) IF (M.NE.0) THEN DO I = 1,M DY(I) = DB*DY(I) + DA*DX(I) END DO END IF IF (N.LT.4) RETURN MP1 = M + 1 DO I = MP1,N,4 DY(I) = DB * DY(I) + DA*DX(I) DY(I+1) = DB * DY(I+1) + DA*DX(I+1) DY(I+2) = DB * DY(I+2) + DA*DX(I+2) DY(I+3) = DB * DY(I+3) + DA*DX(I+3) END DO ELSE * * code for unequal increments or equal increments * not equal to 1 * IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N DY(IY) = DB * DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgebak.f000066400000000000000000000160721522610125300261750ustar00rootroot00000000000000*> \brief \b DGEBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEBAK forms the right or left eigenvectors of a real general matrix *> by backward transformation on the computed eigenvectors of the *> balanced matrix output by DGEBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N', do nothing, return immediately; *> = 'P', do backward transformation for permutation only; *> = 'S', do backward transformation for scaling only; *> = 'B', do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to DGEBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by DGEBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutation and scaling factors, as returned *> by DGEBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by DHSEIN or DTREVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= 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 * * ===================================================================== SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K DOUBLE PRECISION S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL DSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL DSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of DGEBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgebal.f000066400000000000000000000244631522610125300262010ustar00rootroot00000000000000*> \brief \b DGEBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEBAL balances a general real matrix A. This involves, first, *> permuting A by a similarity transformation to isolate eigenvalues *> in the first 1 to ILO-1 and last IHI+1 to N elements on the *> diagonal; and second, applying a diagonal similarity transformation *> to rows and columns ILO to IHI to make the rows and columns as *> close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrix, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A: *> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 *> for i = 1,...,N; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 array, dimension (LDA,N) *> On entry, the input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A is not referenced. *> 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] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE array, dimension (N) *> Details of the permutations and scaling factors applied to *> A. If P(j) is the index of the row and column interchanged *> with row and column j and D(j) is the scaling factor *> applied to row and column j, then *> SCALE(j) = P(j) for j = 1,...,ILO-1 *> = D(j) for j = ILO,...,IHI *> = P(j) for j = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-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 doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The permutations consist of row and column interchanges which put *> the matrix in the form *> *> ( T1 X Y ) *> P A P = ( 0 B Z ) *> ( 0 0 T2 ) *> *> where T1 and T2 are upper triangular matrices whose eigenvalues lie *> along the diagonal. The column indices ILO and IHI mark the starting *> and ending columns of the submatrix B. Balancing consists of applying *> a diagonal similarity transformation inv(D) * B * D to make the *> 1-norms of each row of B and its corresponding column nearly equal. *> The output matrix is *> *> ( T1 X*D Y ) *> ( 0 inv(D)*B*D inv(D)*Z ). *> ( 0 0 T2 ) *> *> Information about the permutations P and the diagonal matrix D is *> returned in the vector SCALE. *> *> This subroutine is based on the EISPACK routine BALANC. *> *> Modified by Tzu-Yi Chen, Computer Science Division, University of *> California at Berkeley, USA *> \endverbatim *> * ===================================================================== SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 * .. * .. External Functions .. LOGICAL DISNAN, LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) 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( 'DGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( A( J, I ).NE.ZERO ) $ GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( A( I, J ).NE.ZERO ) $ GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 * 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L * C = DNRM2( L-K+1, A( K, I ), 1 ) R = DNRM2( L-K+1, A( I, K ), LDA ) ICA = IDAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IDAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 IF( DISNAN( C+F+CA+R+G+RA ) ) THEN * * Exit if NaN to avoid infinite loop * INFO = -3 CALL XERBLA( 'DGEBAL', -INFO ) RETURN END IF F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL DSCAL( N-K+1, G, A( I, K ), LDA ) CALL DSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of DGEBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgebd2.f000066400000000000000000000234501522610125300261050ustar00rootroot00000000000000*> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEBD2 reduces a real general m by n matrix A to upper or lower *> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in 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 general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the orthogonal matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the orthogonal matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the orthogonal matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the orthogonal matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(M,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 June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); *> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); *> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 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 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) A( I, I ) = ONE * * Apply H(i) to A(i:m,i+1:n) from the left * IF( I.LT.N ) $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) A( I, I+1 ) = E( I ) ELSE TAUP( I ) = ZERO END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = A( I, I ) A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAUP( I ), A( I+1, I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(i+1:m,i+1:n) from the left * CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), $ A( I+1, I+1 ), LDA, WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of DGEBD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgebrd.f000066400000000000000000000257471522610125300262200ustar00rootroot00000000000000*> \brief \b DGEBRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEBRD reduces a general real M-by-N matrix A to upper or lower *> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in 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 general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the orthogonal matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the orthogonal matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the orthogonal matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the orthogonal matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \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 >= max(1,M,N). *> For optimum performance LWORK >= (M+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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); *> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); *> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX, WS * .. * .. External Subroutines .. EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = DBLE( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) IF( LWORK.GE.( M+N )*NBMIN ) THEN NB = LWORK / ( M+N ) ELSE NB = 1 NX = MINMN END IF END IF END IF ELSE NX = MINMN END IF * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+nb-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, $ WORK( LDWRKX*NB+1 ), LDWRKY ) * * Update the trailing submatrix A(i+nb:m,i+nb:n), using an update * of the form A := A - V*Y**T - X*U**T * CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, A( I+NB, I ), LDA, $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, $ A( I+NB, I+NB ), LDA ) CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 10 J = I, I + NB - 1 A( J, J ) = D( J ) A( J, J+1 ) = E( J ) 10 CONTINUE ELSE DO 20 J = I, I + NB - 1 A( J, J ) = D( J ) A( J+1, J ) = E( J ) 20 CONTINUE END IF 30 CONTINUE * * Use unblocked code to reduce the remainder of the matrix * CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, IINFO ) WORK( 1 ) = WS RETURN * * End of DGEBRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgecon.f000066400000000000000000000156751522610125300262270ustar00rootroot00000000000000*> \brief \b DGECON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGECON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGECON estimates the reciprocal of the condition number of a general *> real matrix A, in either the 1-norm or the infinity-norm, using *> the LU factorization computed by DGETRF. *> *> An estimate is obtained for norm(inv(A)), and the reciprocal of the *> condition number is computed as *> RCOND = 1 / ( norm(A) * norm(inv(A)) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies whether the 1-norm condition number or the *> infinity-norm condition number is required: *> = '1' or 'O': 1-norm; *> = 'I': Infinity-norm. *> \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) *> The factors L and U from the factorization A = P*L*U *> as computed by DGETRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> If NORM = '1' or 'O', the 1-norm of the original matrix A. *> If NORM = 'I', the infinity-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/(norm(A) * norm(inv(A))). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*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 doubleGEcomputational * * ===================================================================== SUBROUTINE DGECON( NORM, N, A, LDA, 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 NORM INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ONENRM CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) 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 = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGECON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.EQ.ZERO ) THEN RETURN END IF * SMLNUM = DLAMCH( 'Safe minimum' ) * * Estimate the norm of inv(A). * AINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(L). * CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) * * Multiply by inv(U). * CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) ELSE * * Multiply by inv(U**T). * CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) * * Multiply by inv(L**T). * CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) END IF * * Divide X by 1/(SL*SU) if doing so will not cause overflow. * SCALE = SL*SU NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) $ GO TO 20 CALL DRSCL( N, SCALE, WORK, 1 ) END IF GO TO 10 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * 20 CONTINUE RETURN * * End of DGECON * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgees.f000066400000000000000000000420421522610125300260430ustar00rootroot00000000000000*> \brief DGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * .. Function Arguments .. * LOGICAL SELECT * EXTERNAL SELECT * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEES computes for an N-by-N real nonsymmetric matrix A, the *> eigenvalues, the real Schur form T, and, optionally, the matrix of *> Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). *> *> Optionally, it also orders the eigenvalues on the diagonal of the *> real Schur form so that selected eigenvalues are at the top left. *> The leading columns of Z then form an orthonormal basis for the *> invariant subspace corresponding to the selected eigenvalues. *> *> A matrix is in real Schur form if it is upper quasi-triangular with *> 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the *> form *> [ a b ] *> [ c a ] *> *> where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVS *> \verbatim *> JOBVS is CHARACTER*1 *> = 'N': Schur vectors are not computed; *> = 'V': Schur vectors are computed. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELECT). *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> 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. *> If SORT = 'N', SELECT is not referenced. *> An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if *> SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex *> conjugate pair of eigenvalues is selected, then both complex *> eigenvalues are selected. *> Note that a selected complex eigenvalue may no longer *> satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since *> ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned); in this *> case INFO is set to N+2 (see INFO below). *> \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 N-by-N matrix A. *> On exit, A has been overwritten by its real Schur form T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELECT is true. (Complex conjugate *> pairs for which SELECT is true for either *> eigenvalue count as 2.) *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> WR and WI contain the real and imaginary parts, *> respectively, of the computed eigenvalues in the same order *> that they appear on the diagonal of the output Schur form T. *> Complex conjugate pairs of eigenvalues will appear *> consecutively with the eigenvalue having the positive *> imaginary part first. *> \endverbatim *> *> \param[out] VS *> \verbatim *> VS is DOUBLE PRECISION array, dimension (LDVS,N) *> If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur *> vectors. *> If JOBVS = 'N', VS is not referenced. *> \endverbatim *> *> \param[in] LDVS *> \verbatim *> LDVS is INTEGER *> The leading dimension of the array VS. LDVS >= 1; if *> JOBVS = 'V', LDVS >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) contains the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,3*N). *> For good performance, LWORK must generally be larger. *> *> 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] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \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 i is *> <= N: the QR algorithm failed to compute all the *> eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI *> contain those eigenvalues which have converged; if *> JOBVS = 'V', VS contains the matrix which reduces A *> to its partially converged Schur form. *> = N+1: the eigenvalues could not be reordered because some *> eigenvalues were too close to separate (the problem *> is very ill-conditioned); *> = N+2: after reordering, roundoff changed values of some *> complex eigenvalues so that leading eigenvalues in *> the Schur form no longer satisfy SELECT=.TRUE. This *> could also be caused by underflow due to scaling. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, 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 JOBVS, SORT INTEGER INFO, LDA, LDVS, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), $ WR( * ) * .. * .. Function Arguments .. LOGICAL SELECT EXTERNAL SELECT * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, $ WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, $ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, $ DLABAD, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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. * HSWORK refers to the workspace preferred by DHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) MINWRK = 3*N * CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, $ WORK, -1, IEVAL ) HSWORK = WORK( 1 ) * IF( .NOT.WANTVS ) THEN MAXWRK = MAX( MAXWRK, N + HSWORK ) ELSE MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, N + HSWORK ) END IF END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need N) * IBAL = 1 CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (Workspace: need 3*N, prefer 2*N+N*NB) * ITAU = N + IBAL IWRK = N + ITAU CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVS ) THEN * * Copy Householder vectors to VS * CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS ) * * Generate orthogonal matrix in VS * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) END IF * SDIM = 0 * * Perform QR iteration, accumulating Schur vectors in VS if desired * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) IF( IEVAL.GT.0 ) $ INFO = IEVAL * * Sort eigenvalues if desired * IF( WANTST .AND. INFO.EQ.0 ) THEN IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR ) END IF DO 10 I = 1, N BWORK( I ) = SELECT( WR( I ), WI( I ) ) 10 CONTINUE * * Reorder eigenvalues and transform Schur vectors * (Workspace: none needed) * CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, $ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ ICOND ) IF( ICOND.GT.0 ) $ INFO = N + ICOND END IF * IF( WANTVS ) THEN * * Undo balancing * (Workspace: need N) * CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, $ IERR ) END IF * IF( SCALEA ) THEN * * Undo scaling for the Schur form of A * CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) CALL DCOPY( N, A, LDA+1, WR, 1 ) IF( CSCALE.EQ.SMLNUM ) THEN * * If scaling back towards underflow, adjust WI if an * offdiagonal element of a 2-by-2 block in the Schur form * underflows. * IF( IEVAL.GT.0 ) THEN I1 = IEVAL + 1 I2 = IHI - 1 CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, $ MAX( ILO-1, 1 ), IERR ) ELSE IF( WANTST ) THEN I1 = 1 I2 = N - 1 ELSE I1 = ILO I2 = IHI - 1 END IF INXT = I1 - 1 DO 20 I = I1, I2 IF( I.LT.INXT ) $ GO TO 20 IF( WI( I ).EQ.ZERO ) THEN INXT = I + 1 ELSE IF( A( I+1, I ).EQ.ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. $ ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO IF( I.GT.1 ) $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 ) IF( N.GT.I+1 ) $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA, $ A( I+1, I+2 ), LDA ) IF( WANTVS ) THEN CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 ) END IF A( I, I+1 ) = A( I+1, I ) A( I+1, I ) = ZERO END IF INXT = I + 2 END IF 20 CONTINUE END IF * * Undo scaling for the imaginary part of the eigenvalues * CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR ) END IF * IF( WANTST .AND. INFO.EQ.0 ) THEN * * Check if reordering successful * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 30 I = 1, N CURSL = SELECT( WR( I ), WI( I ) ) IF( WI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 30 CONTINUE END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGEES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgegs.f000066400000000000000000000415601522610125300260510ustar00rootroot00000000000000*> \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGGES. *> *> DGEGS computes the eigenvalues, real Schur form, and, optionally, *> 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 *> is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal *> 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 *> DGEGV should be used instead. See DGEGV for a description of the *> eigenvalues of the generalized nonsymmetric eigenvalue problem *> (GNEP). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors (returned in VSL). *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors (returned in VSR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the matrix A. *> On exit, the upper quasi-triangular matrix S from the *> generalized real Schur factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the matrix B. *> On exit, the upper triangular matrix T from the generalized *> real Schur factorization. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> The imaginary parts of each scalar alpha defining an *> eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th *> eigenvalue is real; if positive, then the j-th and (j+1)-st *> eigenvalues are a complex conjugate pair, with *> ALPHAI(j+1) = -ALPHAI(j). *> \endverbatim *> *> \param[out] BETA *> \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 *> mu = beta/alpha. Since either lambda or mu may overflow, *> they should not, in general, be computed. *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', the matrix of left Schur vectors Q. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', the matrix of right Schur vectors Z. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. LWORK >= max(1,4*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: *> NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR *> The optimal LWORK is 2*N + N*(NB+1). *> *> 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. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from DGGBAL *> =N+2: error return from DGEQRF *> =N+3: error return from DORMQR *> =N+4: error return from DORGQR *> =N+5: error return from DGGHRD *> =N+6: error return from DHGEQZ (other than failed *> iteration) *> =N+7: error return from DGGBAK (computing VSL) *> =N+8: error return from DGGBAK (computing VSR) *> =N+9: error return from DLASCL (various places) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, 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 JOBVSL, JOBVSR INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, $ IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN, $ LWKOPT, NB, NB1, NB2, NB3 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SAFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, $ DLASCL, DLASET, DORGQR, DORMQR, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * * Test the input arguments * LWKMIN = MAX( 4*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -12 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -14 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -16 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = 2*N + N*( NB+1 ) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEGS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) SAFMIN = DLAMCH( 'S' ) SMLNUM = N*SAFMIN / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) THEN CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) THEN CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * Workspace layout: (2*N words -- "work..." not actually used) * left_permutation, right_permutation, work... * ILEFT = 1 IRIGHT = N + 1 IWORK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 10 END IF * * Reduce B to triangular form, and initialize VSL and/or VSR * Workspace layout: ("work..." must have at least N words) * left_permutation, right_permutation, tau, work... * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWORK IWORK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 10 END IF * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 10 END IF * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 10 END IF END IF * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 10 END IF * * Perform QZ algorithm, computing Schur vectors if desired * Workspace layout: ("work..." must have at least 1 word) * left_permutation, right_permutation, work... * IWORK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 10 END IF * * Apply permutation to VSL and VSR * IF( ILVSL ) THEN CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 10 END IF END IF IF( ILVSR ) THEN CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 10 END IF END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * 10 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of DGEGS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgehd2.f000066400000000000000000000146761522610125300261250ustar00rootroot00000000000000*> \brief \b DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEHD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by *> an orthogonal similarity transformation: Q**T * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to DGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= max(1,N). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the n by n general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION 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 doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) AII = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i) to A(i+1:ihi,i+1:n) from the left * CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), $ A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = AII 10 CONTINUE * RETURN * * End of DGEHD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgehrd.f000066400000000000000000000252041522610125300262120ustar00rootroot00000000000000*> \brief \b DGEHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGEHRD reduces a real general matrix A to upper Hessenberg form H by *> an orthogonal similarity transformation: Q**T * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to DGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to *> zero. *> \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 >= max(1,N). *> 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 *> 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 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This file is a slight modification of LAPACK-3.0's DGEHRD *> subroutine incorporating improvements proposed by Quintana-Orti and *> Van de Geijn (2006). (See DLAHR2.) *> \endverbatim *> * ===================================================================== SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code * IF( LWORK.LT.N*NB+TSIZE ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN NB = (LWORK-TSIZE) / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * IWT = 1 + N*NB DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V**T * which performs the reduction, and also the matrix Y = A*V*T * CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), $ WORK( IWT ), LDT, WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE 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 ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the * right * CALL DTRMM( 'Right', 'Lower', 'Transpose', $ 'Unit', I, IB-1, $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) DO 30 J = 0, IB-2 CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, $ A( 1, I+J+1 ), 1 ) 30 CONTINUE * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, $ WORK( IWT ), LDT, A( I+1, I+IB ), LDA, $ WORK, LDWORK ) 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = LWKOPT * RETURN * * End of DGEHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgelq2.f000066400000000000000000000120211522610125300261240ustar00rootroot00000000000000*> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGELQ2 computes an LQ factorization of a real m by n matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, 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 *> \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 Q is represented as a product of elementary reflectors *> *> Q = H(k) . . . H(2) H(1), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGELQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), $ A( I+1, I ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGELQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgelqf.f000066400000000000000000000166041522610125300262230ustar00rootroot00000000000000*> \brief \b DGELQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGELQF computes an LQ factorization of a real M-by-N matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \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. LWORK >= max(1,M). *> For optimum performance LWORK >= M*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 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k) . . . H(2) H(1), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGELQF( M, N, A, LDA, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL DLARFB( 'Right', 'No transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGELQF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgelqt.f000066400000000000000000000133701522610125300262360ustar00rootroot00000000000000*> \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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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/MB), where each *> block is of order MB except for the last block, which is of order *> IB = K - (B-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-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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, DGELQT3, 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgelqt3.f000066400000000000000000000162541522610125300263250ustar00rootroot00000000000000*> \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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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, 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgemlqt.f000066400000000000000000000175521522610125300264210ustar00rootroot00000000000000*> \brief \b DGEMLQT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEMLQT + 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 *> *> DGEMLQT 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,M) if SIDE = 'L', *> (LDV,N) if SIDE = 'R' *> 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. LDV >= max(1,K). *> \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-K 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 November 2017 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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 * .. * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgemqr.f000066400000000000000000000172471522610125300262440ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgemqrt.f000066400000000000000000000175751522610125300264340ustar00rootroot00000000000000*> \brief \b DGEMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. 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 DGEQRT. *> *> 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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CGEQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRT in the first K columns 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 CGEQRT, stored as a NB-by-N matrix. *> \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, 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*NB if SIDE = 'L', or M*NB 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 DGEMQRT( SIDE, TRANS, M, N, K, NB, 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, NB, 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 ) Q = M ELSE IF ( RIGHT ) THEN LDWORK = MAX( 1, M ) Q = N 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 .OR. K.GT.Q ) THEN INFO = -5 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * 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, $ 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * 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, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * ELSE IF( RIGHT .AND. TRAN ) THEN * 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * END IF * RETURN * * End of DGEMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqp3.f000066400000000000000000000237351522610125300261470ustar00rootroot00000000000000*> \brief \b DGEQP3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQP3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQP3 computes a QR factorization with column pivoting of a *> matrix A: A*P = Q*R using Level 3 BLAS. *> \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 upper triangle of the array contains the *> min(M,N)-by-N upper trapezoidal matrix R; the elements below *> the diagonal, together with the array TAU, represent the *> orthogonal matrix Q as a product of min(M,N) elementary *> reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(J).ne.0, the J-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(J)=0, *> the J-th column of A is a free column. *> On exit, if JPVT(J)=K, then the J-th column of A*P was the *> the K-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \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. LWORK >= 3*N+1. *> For optimal performance LWORK >= 2*N+( 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. *> \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 Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real/complex vector *> with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in *> A(i+1:m,i), and tau in TAU(i). *> \endverbatim * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> * ===================================================================== SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN * .. * .. External Subroutines .. EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DNRM2 EXTERNAL ILAENV, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test input arguments * ==================== * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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 END IF * IF( INFO.EQ.0 ) THEN MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN IWS = 1 LWKOPT = 1 ELSE IWS = 3*N + 1 NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) LWKOPT = 2*N + ( N + 1 )*NB END IF WORK( 1 ) = LWKOPT * IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQP3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Move initial columns up front. * NFXD = 1 DO 10 J = 1, N IF( JPVT( J ).NE.0 ) THEN IF( J.NE.NFXD ) THEN CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) JPVT( J ) = JPVT( NFXD ) JPVT( NFXD ) = J ELSE JPVT( J ) = J END IF NFXD = NFXD + 1 ELSE JPVT( J ) = J END IF 10 CONTINUE NFXD = NFXD - 1 * * Factorize fixed columns * ======================= * * Compute the QR factorization of fixed columns and update * remaining columns. * IF( NFXD.GT.0 ) THEN NA = MIN( M, NFXD ) *CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) IF( NA.LT.N ) THEN *CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, *CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU, $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) END IF END IF * * Factorize free columns * ====================== * IF( NFXD.LT.MINMN ) THEN * SM = M - NFXD SN = N - NFXD SMINMN = MINMN - NFXD * * Determine the block size. * NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) NBMIN = 2 NX = 0 * IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, $ -1 ) ) * * IF( NX.LT.SMINMN ) THEN * * Determine if workspace is large enough for blocked code. * MINWS = 2*SN + ( SN+1 )*NB IWS = MAX( IWS, MINWS ) IF( LWORK.LT.MINWS ) THEN * * Not enough workspace to use optimal NB: Reduce NB and * determine the minimum value of NB. * NB = ( LWORK-2*SN ) / ( SN+1 ) NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN, $ -1, -1 ) ) * * END IF END IF END IF * * Initialize partial column norms. The first N elements of work * store the exact column norms. * DO 20 J = NFXD + 1, N WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) WORK( N+J ) = WORK( J ) 20 CONTINUE * IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. $ ( NX.LT.SMINMN ) ) THEN * * Use blocked code initially. * J = NFXD + 1 * * Compute factorization: while loop. * * TOPBMN = MINMN - NX 30 CONTINUE IF( J.LE.TOPBMN ) THEN JB = MIN( NB, TOPBMN-J+1 ) * * Factorize JB columns among columns J:N. * CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) * J = J + FJB GO TO 30 END IF ELSE J = NFXD + 1 END IF * * Use unblocked code to factor the last or only block. * * IF( J.LE.MINMN ) $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), $ TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ) ) * END IF * WORK( 1 ) = IWS RETURN * * End of DGEQP3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqpf.f000066400000000000000000000211751522610125300262260ustar00rootroot00000000000000*> \brief \b DGEQPF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQPF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGEQP3. *> *> DGEQPF computes a QR factorization with column pivoting of a *> real M-by-N matrix A: A*P = 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. 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 upper triangle of the array contains the *> min(M,N)-by-N upper triangular matrix R; the elements *> below the diagonal, together with the array TAU, *> represent the orthogonal matrix Q as a product of *> min(m,n) elementary reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*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 Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(n) *> *> Each H(i) has the form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). *> *> The matrix P is represented in jpvt as follows: If *> jpvt(j) = i *> then the jth column of P is the ith canonical unit vector. *> *> Partial column norm updating strategy modified by *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. *> -- April 2011 -- *> For more details see LAPACK Working Note 176. *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, 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, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQPF', -INFO ) RETURN END IF * MN = MIN( M, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU, $ A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n elements of * work store the exact column norms. * DO 20 I = ITEMP + 1, N WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) WORK( N+I ) = WORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i) * IF( I.LT.M ) THEN CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN * * 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( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = ZERO WORK( N+J ) = ZERO END IF ELSE WORK( J ) = WORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of DGEQPF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqr.f000066400000000000000000000225411522610125300260600ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqr2.f000066400000000000000000000120121522610125300261320ustar00rootroot00000000000000*> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGEQR2 computes a QR factorization of a real m by n matrix A: *> 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. 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION 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 doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQR2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGEQR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqrf.f000066400000000000000000000166341522610125300262340ustar00rootroot00000000000000*> \brief \b DGEQRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGEQRF computes a QR factorization of a real M-by-N matrix A: *> 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. 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, *> with the array TAU, represent the orthogonal matrix Q as a *> product of min(m,n) elementary reflectors (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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \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. LWORK >= max(1,N). *> For optimum performance LWORK >= 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 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRF( M, N, A, LDA, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * 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 ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H**T to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGEQRF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqrt.f000066400000000000000000000137701522610125300262500ustar00rootroot00000000000000*> \brief \b DGEQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGEQRT computes a blocked QR 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] NB *> \verbatim *> NB is INTEGER *> The block size to be used in the blocked QR. MIN(M,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 min(M,N)-by-N upper trapezoidal matrix R (R is *> upper triangular if M >= N); the elements below the diagonal *> are the columns 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 >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (NB*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 June 2017 * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, IINFO, K LOGICAL USE_RECURSIVE_QR PARAMETER( USE_RECURSIVE_QR=.TRUE. ) * .. * .. 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( NB.LT.1 .OR. ( NB.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.NB ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRT', -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, 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 CALL DGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) ELSE CALL DGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) END IF IF( I+IB.LE.N ) THEN * * 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+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN * * End of DGEQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqrt2.f000066400000000000000000000141621522610125300263260ustar00rootroot00000000000000*> \brief \b DGEQRT2 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/ * *> \htmlonly *> Download DGEQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> \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 *> 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. *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRT2( 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, LDT, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER( ONE = 1.0D+00, ZERO = 0.0D+00 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII, ALPHA * .. * .. External Subroutines .. EXTERNAL DLARFG, DGEMV, DGER, DTRMV, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRT2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO I = 1, K * * Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ T( I, 1 ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(I:M,I+1:N) from the left * AII = A( I, I ) A( I, I ) = ONE * * 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, $ 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, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF END DO * DO I = 2, N AII = A( I, I ) A( I, I ) = ONE * * 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, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO * * End of DGEQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgeqrt3.f000066400000000000000000000162671522610125300263370ustar00rootroot00000000000000*> \brief \b DGEQRT3 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/ * *> \htmlonly *> Download DGEQRT3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> *> 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 *> 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. *> \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 June 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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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 DGEQRT3( 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..-- * June 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, N1, N2, IINFO * .. * .. External Subroutines .. EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N .LT. 0 ) THEN INFO = -2 ELSE IF( M .LT. N ) THEN INFO = -1 ELSE IF( LDA .LT. MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT .LT. MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRT3', -INFO ) RETURN END IF * IF( N.EQ.1 ) THEN * * Compute Householder transform when N=1 * CALL DLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) * ELSE * * Otherwise, split A into blocks... * N1 = N/2 N2 = N-N1 J1 = MIN( N1+1, N ) I1 = MIN( N+1, M ) * * Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H * CALL DGEQRT3( M, N1, A, LDA, T, LDT, IINFO ) * * Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] * DO J=1,N2 DO I=1,N1 T( I, J+N1 ) = A( I, J+N1 ) END DO END DO 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, & A( J1, J1 ), LDA, ONE, T( 1, J1 ), LDT) * 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, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL DTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * DO J=1,N2 DO I=1,N1 A( I, J+N1 ) = A( I, J+N1 ) - T( I, J+N1 ) END DO END DO * * 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, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 * DO I=1,N1 DO J=1,N2 T( I, J+N1 ) = (A( J+N1, I )) END DO END DO * 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, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), 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, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] * [ 0 R2 ] [ 0 T2] * END IF * RETURN * * End of DGEQRT3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgerq2.f000066400000000000000000000121671522610125300261450ustar00rootroot00000000000000*> \brief \b DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGERQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGERQ2 computes an RQ factorization of a real m by n matrix A: *> A = R * 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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the m by n matrix A. *> On exit, if m <= n, the upper triangle of the subarray *> A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; *> if m >= n, the elements on and above the (m-n)-th subdiagonal *> contain the m by n upper trapezoidal matrix R; the remaining *> elements, 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, 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 *> \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 Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in *> A(m-k+i,1:n-k+i-1), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGERQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGERQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = K, 1, -1 * * Generate elementary reflector H(i) to annihilate * A(m-k+i,1:n-k+i-1) * CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * AII = A( M-K+I, N-K+I ) A( M-K+I, N-K+I ) = ONE CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, $ TAU( I ), A, LDA, WORK ) A( M-K+I, N-K+I ) = AII 10 CONTINUE RETURN * * End of DGERQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgerqf.f000066400000000000000000000176361522610125300262370ustar00rootroot00000000000000*> \brief \b DGERQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGERQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DGERQF computes an RQ factorization of a real M-by-N matrix A: *> A = R * 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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, *> if m <= n, the upper triangle of the subarray *> A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; *> if m >= n, the elements on and above the (m-n)-th subdiagonal *> contain the M-by-N upper trapezoidal matrix R; *> the remaining elements, with the array TAU, represent the *> orthogonal matrix Q as a product of min(m,n) elementary *> reflectors (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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \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. LWORK >= max(1,M). *> For optimum performance LWORK >= M*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 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in *> A(m-k+i,1:n-k+i-1), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DGERQF( M, N, A, LDA, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, $ MU, NB, NBMIN, NU, NX * .. * .. External Subroutines .. EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF * IF( INFO.EQ.0 ) THEN K = MIN( M, N ) IF( K.EQ.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGERQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( K.EQ.0 ) THEN RETURN END IF * NBMIN = 2 NX = 1 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially. * The last kk rows are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * DO 10 I = K - KK + KI + 1, K - KK + 1, -NB IB = MIN( K-I+1, NB ) * * Compute the RQ factorization of the current block * A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) * CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ), $ WORK, IINFO ) IF( M-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, $ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right * CALL DLARFB( 'Right', 'No transpose', 'Backward', $ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB, $ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE MU = M - K + I + NB - 1 NU = N - K + I + NB - 1 ELSE MU = M NU = N END IF * * Use unblocked code to factor the last or only block * IF( MU.GT.0 .AND. NU.GT.0 ) $ CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGERQF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgesc2.f000066400000000000000000000124711522610125300261260ustar00rootroot00000000000000*> \brief \b DGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * .. Scalar Arguments .. * INTEGER LDA, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION A( LDA, * ), RHS( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESC2 solves a system of linear equations *> *> A * X = scale* RHS *> *> with a general N-by-N matrix A using the LU factorization with *> complete pivoting computed by DGETC2. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the LU part of the factorization of the n-by-n *> matrix A computed by DGETC2: A = P * L * U * Q *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is DOUBLE PRECISION array, dimension (N). *> On entry, the right hand side vector b. *> On exit, the solution vector X. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, SCALE contains the scale factor. SCALE is chosen *> 0 <= SCALE <= 1 to prevent owerflow in the solution. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) DOUBLE PRECISION A( LDA, * ), RHS( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP * .. * .. External Subroutines .. EXTERNAL DLASWP, DSCAL * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL IDAMAX, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Set constant to control owerflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Apply permutations IPIV to RHS * CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) * * Solve for L part * DO 20 I = 1, N - 1 DO 10 J = I + 1, N RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) 10 CONTINUE 20 CONTINUE * * Solve for U part * SCALE = ONE * * Check for scaling * I = IDAMAX( N, RHS, 1 ) IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN TEMP = ( ONE / TWO ) / ABS( RHS( I ) ) CALL DSCAL( N, TEMP, RHS( 1 ), 1 ) SCALE = SCALE*TEMP END IF * DO 40 I = N, 1, -1 TEMP = ONE / A( I, I ) RHS( I ) = RHS( I )*TEMP DO 30 J = I + 1, N RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) 30 CONTINUE 40 CONTINUE * * Apply permutations JPIV to the solution (RHS) * CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) RETURN * * End of DGESC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgetc2.f000066400000000000000000000142051522610125300261240ustar00rootroot00000000000000*> \brief \b DGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGETC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGETC2 computes an LU factorization with complete pivoting of the *> n-by-n matrix A. The factorization has the form A = P * L * U * Q, *> where P and Q are permutation matrices, L is lower triangular with *> unit diagonal elements and U is upper triangular. *> *> This is the Level 2 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \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 n-by-n matrix A to be factored. *> On exit, the factors L and U from the factorization *> A = P*L*U*Q; the unit diagonal elements of L are not stored. *> If U(k, k) appears to be less than SMIN, U(k, k) is given the *> value of SMIN, i.e., giving a nonsingular perturbed system. *> \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). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension(N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = k, U(k, k) is likely to produce owerflow if *> we try to solve for x in Ax = b. So U is perturbed to *> avoid the overflow. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IP, IPV, J, JP, JPV DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSWAP * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Handle the case N=1 by itself * IF( N.EQ.1 ) THEN IPIV( 1 ) = 1 JPIV( 1 ) = 1 IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN INFO = 1 A( 1, 1 ) = SMLNUM END IF RETURN END IF * * Factorize A using complete pivoting. * Set pivots less than SMIN to SMIN. * DO 40 I = 1, N - 1 * * Find max element in matrix A * XMAX = ZERO DO 20 IP = I, N DO 10 JP = I, N IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( A( IP, JP ) ) IPV = IP JPV = JP END IF 10 CONTINUE 20 CONTINUE IF( I.EQ.1 ) $ SMIN = MAX( EPS*XMAX, SMLNUM ) * * Swap rows * IF( IPV.NE.I ) $ CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) IPIV( I ) = IPV * * Swap columns * IF( JPV.NE.I ) $ CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) JPIV( I ) = JPV * * Check for singularity * IF( ABS( A( I, I ) ).LT.SMIN ) THEN INFO = I A( I, I ) = SMIN END IF DO 30 J = I + 1, N A( J, I ) = A( J, I ) / A( I, I ) 30 CONTINUE CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA, $ A( I+1, I+1 ), LDA ) 40 CONTINUE * IF( ABS( A( N, N ) ).LT.SMIN ) THEN INFO = N A( N, N ) = SMIN END IF * * Set last pivots to N * IPIV( N ) = N JPIV( N ) = N * RETURN * * End of DGETC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dggbak.f000066400000000000000000000202431522610125300261720ustar00rootroot00000000000000*> \brief \b DGGBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGBAK forms the right or left eigenvectors of a real generalized *> eigenvalue problem A*x = lambda*B*x, by backward transformation on *> the computed eigenvectors of the balanced pair of matrices output by *> DGGBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N': do nothing, return immediately; *> = 'P': do backward transformation for permutation only; *> = 'S': do backward transformation for scaling only; *> = 'B': do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to DGGBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by DGGBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the left side of A and B, as returned by DGGBAL. *> \endverbatim *> *> \param[in] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the right side of A and B, as returned by DGGBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by DTGEVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the matrix V. LDV >= 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 doubleGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. Ward, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, INT * .. * .. Executable Statements .. * * Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN INFO = -4 ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) $ THEN INFO = -5 ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward transformation on right eigenvectors * IF( RIGHTV ) THEN DO 10 I = ILO, IHI CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) 10 CONTINUE END IF * * Backward transformation on left eigenvectors * IF( LEFTV ) THEN DO 20 I = ILO, IHI CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) 20 CONTINUE END IF END IF * * Backward permutation * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward permutation on right eigenvectors * IF( RIGHTV ) THEN IF( ILO.EQ.1 ) $ GO TO 50 * DO 40 I = ILO - 1, 1, -1 K = INT(RSCALE( I )) IF( K.EQ.I ) $ GO TO 40 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE * 50 CONTINUE IF( IHI.EQ.N ) $ GO TO 70 DO 60 I = IHI + 1, N K = INT(RSCALE( I )) IF( K.EQ.I ) $ GO TO 60 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 60 CONTINUE END IF * * Backward permutation on left eigenvectors * 70 CONTINUE IF( LEFTV ) THEN IF( ILO.EQ.1 ) $ GO TO 90 DO 80 I = ILO - 1, 1, -1 K = INT(LSCALE( I )) IF( K.EQ.I ) $ GO TO 80 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 80 CONTINUE * 90 CONTINUE IF( IHI.EQ.N ) $ GO TO 110 DO 100 I = IHI + 1, N K = INT(LSCALE( I )) IF( K.EQ.I ) $ GO TO 100 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 100 CONTINUE END IF END IF * 110 CONTINUE * RETURN * * End of DGGBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dggbal.f000066400000000000000000000366201522610125300262010ustar00rootroot00000000000000*> \brief \b DGGBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), * $ RSCALE( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGBAL balances a pair of general real matrices (A,B). This *> involves, first, permuting A and B by similarity transformations to *> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N *> elements on the diagonal; and second, applying a diagonal similarity *> transformation to rows and columns ILO to IHI to make the rows *> and columns as close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrices, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors in the *> generalized eigenvalue problem A*x = lambda*B*x. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A and B: *> = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 *> and RSCALE(I) = 1.0 for i = 1,...,N. *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A 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,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the input matrix B. *> On exit, B is overwritten by the balanced matrix. *> If JOB = 'N', B is not referenced. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 and B(i,j) = 0 if i > j and *> j = 1,...,ILO-1 or i = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> to the left side of A and B. If P(j) is the index of the *> row interchanged with row j, and D(j) *> is the scaling factor applied to row j, then *> LSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> to the right side of A and B. If P(j) is the index of the *> column interchanged with column j, and D(j) *> is the scaling factor applied to column j, then *> LSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> 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 *> *> \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 doubleGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. WARD, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), $ RSCALE( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION THREE, SCLFAC PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) * .. * .. Local Scalars .. INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, $ M, NR, NRP2 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * IF( N.EQ.1 ) THEN ILO = 1 IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N DO 10 I = 1, N LSCALE( I ) = ONE RSCALE( I ) = ONE 10 CONTINUE RETURN END IF * K = 1 L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * GO TO 30 * * Permute the matrices A and B to isolate the eigenvalues. * * Find row with one nonzero in columns 1 through L * 20 CONTINUE L = LM1 IF( L.NE.1 ) $ GO TO 30 * RSCALE( 1 ) = ONE LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE LM1 = L - 1 DO 80 I = L, 1, -1 DO 40 J = 1, LM1 JP1 = J + 1 IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 50 40 CONTINUE J = L GO TO 70 * 50 CONTINUE DO 60 J = JP1, L IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 80 60 CONTINUE J = JP1 - 1 * 70 CONTINUE M = L IFLOW = 1 GO TO 160 80 CONTINUE GO TO 100 * * Find column with one nonzero in rows K through N * 90 CONTINUE K = K + 1 * 100 CONTINUE DO 150 J = K, L DO 110 I = K, LM1 IP1 = I + 1 IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 120 110 CONTINUE I = L GO TO 140 120 CONTINUE DO 130 I = IP1, L IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 150 130 CONTINUE I = IP1 - 1 140 CONTINUE M = K IFLOW = 2 GO TO 160 150 CONTINUE GO TO 190 * * Permute rows M and I * 160 CONTINUE LSCALE( M ) = I IF( I.EQ.M ) $ GO TO 170 CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) * * Permute columns M and J * 170 CONTINUE RSCALE( M ) = J IF( J.EQ.M ) $ GO TO 180 CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) * 180 CONTINUE GO TO ( 20, 90 )IFLOW * 190 CONTINUE ILO = K IHI = L * IF( LSAME( JOB, 'P' ) ) THEN DO 195 I = ILO, IHI LSCALE( I ) = ONE RSCALE( I ) = ONE 195 CONTINUE RETURN END IF * IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 DO 200 I = ILO, IHI RSCALE( I ) = ZERO LSCALE( I ) = ZERO * WORK( I ) = ZERO WORK( I+N ) = ZERO WORK( I+2*N ) = ZERO WORK( I+3*N ) = ZERO WORK( I+4*N ) = ZERO WORK( I+5*N ) = ZERO 200 CONTINUE * * Compute right side vector in resulting linear equations * BASL = LOG10( SCLFAC ) DO 240 I = ILO, IHI DO 230 J = ILO, IHI TB = B( I, J ) TA = A( I, J ) IF( TA.EQ.ZERO ) $ GO TO 210 TA = LOG10( ABS( TA ) ) / BASL 210 CONTINUE IF( TB.EQ.ZERO ) $ GO TO 220 TB = LOG10( ABS( TB ) ) / BASL 220 CONTINUE WORK( I+4*N ) = WORK( I+4*N ) - TA - TB WORK( J+5*N ) = WORK( J+5*N ) - TA - TB 230 CONTINUE 240 CONTINUE * COEF = ONE / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO IT = 1 * * Start generalized conjugate gradient iteration * 250 CONTINUE * GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) * EW = ZERO EWC = ZERO DO 260 I = ILO, IHI EW = EW + WORK( I+4*N ) EWC = EWC + WORK( I+5*N ) 260 CONTINUE * GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC-THREE*EW ) TC = COEF5*( EW-THREE*EWC ) * CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) * CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) * DO 270 I = ILO, IHI WORK( I ) = WORK( I ) + TC WORK( I+N ) = WORK( I+N ) + T 270 CONTINUE * * Apply matrix to vector * DO 300 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 290 J = ILO, IHI IF( A( I, J ).EQ.ZERO ) $ GO TO 280 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 280 CONTINUE IF( B( I, J ).EQ.ZERO ) $ GO TO 290 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 290 CONTINUE WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM 300 CONTINUE * DO 330 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 320 I = ILO, IHI IF( A( I, J ).EQ.ZERO ) $ GO TO 310 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 310 CONTINUE IF( B( I, J ).EQ.ZERO ) $ GO TO 320 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 320 CONTINUE WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM 330 CONTINUE * SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) ALPHA = GAMMA / SUM * * Determine correction to current iteration * CMAX = ZERO DO 340 I = ILO, IHI COR = ALPHA*WORK( I+N ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR COR = ALPHA*WORK( I ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( I ) = RSCALE( I ) + COR 340 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 350 * CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) * PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 250 * * End generalized conjugate gradient iteration * 350 CONTINUE SFMIN = DLAMCH( 'S' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) DO 360 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = INT(LSCALE( I ) + SIGN( HALF, LSCALE( I ) )) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR ICAB = IDAMAX( IHI, A( 1, I ), 1 ) CAB = ABS( A( ICAB, I ) ) ICAB = IDAMAX( IHI, B( 1, I ), 1 ) CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) JC = INT(RSCALE( I ) + SIGN( HALF, RSCALE( I ) )) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( I ) = SCLFAC**JC 360 CONTINUE * * Row scaling of matrices A and B * DO 370 I = ILO, IHI CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) 370 CONTINUE * * Column scaling of matrices A and B * DO 380 J = ILO, IHI CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) 380 CONTINUE * RETURN * * End of DGGBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgges.f000066400000000000000000000543651522610125300260600ustar00rootroot00000000000000*> \brief DGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), *> the generalized eigenvalues, the generalized real Schur form (S,T), *> optionally, the left and/or right matrices of Schur vectors (VSL and *> VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> quasi-triangular matrix S and the upper triangular matrix T.The *> leading columns of VSL and VSR then form an orthonormal basis for the *> corresponding left and right eigenspaces (deflating subspaces). *> *> (If only the generalized eigenvalues are needed, use the driver *> DGGEV instead, which is faster.) *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0 or both being zero. *> *> A pair of matrices (S,T) is in generalized real Schur form if T is *> upper triangular with non-negative diagonal and S is block upper *> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond *> to real generalized eigenvalues, while 2-by-2 blocks of S will be *> "standardized" by making the corresponding elements of T have the *> form: *> [ a 0 ] *> [ 0 b ] *> *> and the pair of corresponding 2-by-2 blocks in S and T will have a *> complex conjugate pair of generalized eigenvalues. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG); *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if *> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either *> one of a complex conjugate pair of eigenvalues is selected, *> then both complex eigenvalues are selected. *> *> Note that in the ill-conditioned case, a selected complex *> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), *> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 *> in this case. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. (Complex conjugate pairs for which *> SELCTG is true for either eigenvalue count as 2.) *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real Schur form of (A,B) were further reduced to *> triangular form using 2-by-2 complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio. *> However, ALPHAR and ALPHAI will be always less than and *> usually comparable with norm(A) in magnitude, and BETA always *> less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. *> If N = 0, LWORK >= 1, else LWORK >= 8*N+16. *> For good performance , LWORK must generally be larger. *> *> 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] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in DHGEQZ. *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in DTGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * * ===================================================================== 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.7.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 JOBVSL, JOBVSR, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, LST2SL, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, $ MINWRK DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, $ PVSR, SAFMAX, SAFMIN, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -15 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -17 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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.) * IF( INFO.EQ.0 ) THEN IF( N.GT.0 )THEN MINWRK = MAX( 8*N, 6*N + 16 ) MAXWRK = MINWRK - N + $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) ) IF( ILVSL ) THEN MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) END IF ELSE MINWRK = 1 MAXWRK = 1 END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SQRT( SAFMIN ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need 6*N + 2*N space for storing balancing factors) * ILEFT = 1 IRIGHT = N + 1 IWRK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWRK IWRK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Workspace: need N, prefer N*NB) * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * (Workspace: need N, prefer N*NB) * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IERR ) * * Perform QZ algorithm, computing Schur vectors if desired * (Workspace: need N) * IWRK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWRK ), LWORK+1-IWRK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 50 END IF * * Sort eigenvalues ALPHA/BETA if desired * (Workspace: need 4*N+16 ) * SDIM = 0 IF( WANTST ) THEN * * Undo scaling on eigenvalues before SELCTGing * IF( ILASCL ) THEN CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IERR ) END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) 10 CONTINUE * CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ IERR ) IF( IERR.EQ.1 ) $ INFO = N + 3 * END IF * * Apply back-permutation to VSL and VSR * (Workspace: none needed) * IF( ILVSL ) $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) * IF( ILVSR ) $ CALL DGGBAK( '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 * 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( 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 ) ) 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 ) .OR. $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) $ THEN WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 20 CONTINUE END IF * IF( ILBSCL ) THEN DO 30 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN WORK( 1 ) = ABS( B( I, I ) / BETA( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 30 CONTINUE END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 40 I = 1, N CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) IF( ALPHAI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 40 CONTINUE * END IF * 50 CONTINUE * WORK( 1 ) = MAXWRK * RETURN * * End of DGGES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgges3.f000066400000000000000000000542441522610125300261370ustar00rootroot00000000000000*> \brief DGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm) * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGES3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGES3( 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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B), *> the generalized eigenvalues, the generalized real Schur form (S,T), *> optionally, the left and/or right matrices of Schur vectors (VSL and *> VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> quasi-triangular matrix S and the upper triangular matrix T.The *> leading columns of VSL and VSR then form an orthonormal basis for the *> corresponding left and right eigenspaces (deflating subspaces). *> *> (If only the generalized eigenvalues are needed, use the driver *> DGGEV instead, which is faster.) *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0 or both being zero. *> *> A pair of matrices (S,T) is in generalized real Schur form if T is *> upper triangular with non-negative diagonal and S is block upper *> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond *> to real generalized eigenvalues, while 2-by-2 blocks of S will be *> "standardized" by making the corresponding elements of T have the *> form: *> [ a 0 ] *> [ 0 b ] *> *> and the pair of corresponding 2-by-2 blocks in S and T will have a *> complex conjugate pair of generalized eigenvalues. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG); *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if *> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either *> one of a complex conjugate pair of eigenvalues is selected, *> then both complex eigenvalues are selected. *> *> Note that in the ill-conditioned case, a selected complex *> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), *> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 *> in this case. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. (Complex conjugate pairs for which *> SELCTG is true for either eigenvalue count as 2.) *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real Schur form of (A,B) were further reduced to *> triangular form using 2-by-2 complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio. *> However, ALPHAR and ALPHAI will be always less than and *> usually comparable with norm(A) in magnitude, and BETA always *> less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. *> *> 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] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in DHGEQZ. *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in DTGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date January 2015 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGGES3( 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.6.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, LST2SL, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, LWKOPT DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, $ PVSR, SAFMAX, SAFMIN, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHD3, DHGEQZ, DLABAD, $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -15 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -17 ELSE IF( LWORK.LT.6*N+16 .AND. .NOT.LQUERY ) THEN INFO = -19 END IF * * Compute workspace * IF( INFO.EQ.0 ) THEN CALL DGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) LWKOPT = MAX( 6*N+16, 3*N+INT( WORK ( 1 ) ) ) CALL DORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, $ -1, IERR ) LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) IF( ILVSL ) THEN CALL DORGQR( N, N, N, VSL, LDVSL, WORK, WORK, -1, IERR ) LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) END IF CALL DGGHD3( JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK, -1, IERR ) LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) IF( WANTST ) THEN CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ SDIM, PVSL, PVSR, DIF, WORK, -1, IDUM, 1, $ IERR ) LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGES3 ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SQRT( SAFMIN ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * ILEFT = 1 IRIGHT = N + 1 IWRK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWRK IWRK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL DGGHD3( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, WORK( IWRK ), LWORK+1-IWRK, $ IERR ) * * Perform QZ algorithm, computing Schur vectors if desired * IWRK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWRK ), LWORK+1-IWRK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 50 END IF * * Sort eigenvalues ALPHA/BETA if desired * SDIM = 0 IF( WANTST ) THEN * * Undo scaling on eigenvalues before SELCTGing * IF( ILASCL ) THEN CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IERR ) END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) 10 CONTINUE * CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ IERR ) IF( IERR.EQ.1 ) $ INFO = N + 3 * END IF * * Apply back-permutation to VSL and VSR * IF( ILVSL ) $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) * IF( ILVSR ) $ CALL DGGBAK( '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 * 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( 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 ) ) 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 ) .OR. $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) $ THEN WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 20 CONTINUE END IF * IF( ILBSCL ) THEN DO 30 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN WORK( 1 ) = ABS( B( I, I ) / BETA( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 30 CONTINUE END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 40 I = 1, N CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) IF( ALPHAI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 40 CONTINUE * END IF * 50 CONTINUE * WORK( 1 ) = LWKOPT * RETURN * * End of DGGES3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgghd3.f000066400000000000000000000764131522610125300261250ustar00rootroot00000000000000*> \brief \b DGGHD3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGHD3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * LDQ, Z, LDZ, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ * INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGHD3 reduces a pair of real matrices (A,B) to generalized upper *> Hessenberg form using orthogonal transformations, where A is a *> general matrix and B is upper triangular. The form of the *> generalized eigenvalue problem is *> A*x = lambda*B*x, *> and B is typically made upper triangular by computing its QR *> factorization and moving the orthogonal matrix Q to the left side *> of the equation. *> *> This subroutine simultaneously reduces A to a Hessenberg matrix H: *> Q**T*A*Z = H *> and transforms B to another upper triangular matrix T: *> Q**T*B*Z = T *> in order to reduce the problem to its standard form *> H*y = lambda*T*y *> where y = Z**T*x. *> *> The orthogonal matrices Q and Z are determined as products of Givens *> rotations. They may either be formed explicitly, or they may be *> postmultiplied into input matrices Q1 and Z1, so that *> *> Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T *> *> Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T *> *> If Q1 is the orthogonal matrix from the QR factorization of B in the *> original equation A*x = lambda*B*x, then DGGHD3 reduces the original *> problem to generalized Hessenberg form. *> *> This is a blocked variant of DGGHRD, using matrix-matrix *> multiplications for parts of the computation to enhance performance. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': do not compute Q; *> = 'I': Q is initialized to the unit matrix, and the *> orthogonal matrix Q is returned; *> = 'V': Q must contain an orthogonal matrix Q1 on entry, *> and the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': do not compute Z; *> = 'I': Z is initialized to the unit matrix, and the *> orthogonal matrix Z is returned; *> = 'V': Z must contain an orthogonal matrix Z1 on entry, *> and the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI mark the rows and columns of A which are to be *> reduced. It is assumed that A is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are *> normally set by a previous call to DGGBAL; otherwise they *> should be set to 1 and N respectively. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, and the *> rest is set to zero. *> \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 N-by-N upper triangular matrix B. *> On exit, the upper triangular matrix T = Q**T B Z. The *> elements below the diagonal are set to zero. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the orthogonal matrix Q1, *> typically from the QR factorization of B. *> On exit, if COMPQ='I', the orthogonal matrix Q, and if *> COMPQ = 'V', the product Q1*Q. *> Not referenced if COMPQ='N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the orthogonal matrix Z1. *> On exit, if COMPZ='I', the orthogonal matrix Z, and if *> COMPZ = 'V', the product Z1*Z. *> Not referenced if COMPZ='N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. *> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. *> \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. *> For optimum performance LWORK >= 6*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 January 2015 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine reduces A to Hessenberg form and maintains B in *> using a blocked variant of Moler and Stewart's original algorithm, *> as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti *> (BIT 2008). *> \endverbatim *> * ===================================================================== SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, WORK, LWORK, INFO ) * * -- 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 * IMPLICIT NONE * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ CHARACTER*1 COMPQ2, COMPZ2 INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K, $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN, $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ DOUBLE PRECISION C, C1, C2, S, S1, S2, TEMP, TEMP1, TEMP2, TEMP3 * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL DGGHRD, DLARTG, DLASET, DORM22, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * INFO = 0 NB = ILAENV( 1, 'DGGHD3', ' ', N, ILO, IHI, -1 ) LWKOPT = MAX( 6*N*NB, 1 ) WORK( 1 ) = DBLE( LWKOPT ) INITQ = LSAME( COMPQ, 'I' ) WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( WANTQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( WANTZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGHD3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Initialize Q and Z if desired. * IF( INITQ ) $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) IF( INITZ ) $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) * * Zero out lower triangle of B. * IF( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2, 1), LDB ) * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = ONE RETURN END IF * * Determine the blocksize. * NBMIN = ILAENV( 2, 'DGGHD3', ' ', N, ILO, IHI, -1 ) IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to use unblocked instead of blocked code. * NX = MAX( NB, ILAENV( 3, 'DGGHD3', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code. * IF( LWORK.LT.LWKOPT ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code. * NBMIN = MAX( 2, ILAENV( 2, 'DGGHD3', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.6*N*NBMIN ) THEN NB = LWORK / ( 6*N ) ELSE NB = 1 END IF END IF END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * JCOL = ILO * ELSE * * Use blocked code * KACC22 = ILAENV( 16, 'DGGHD3', ' ', N, ILO, IHI, -1 ) BLK22 = KACC22.EQ.2 DO JCOL = ILO, IHI-2, NB NNB = MIN( NB, IHI-JCOL-1 ) * * Initialize small orthogonal factors that will hold the * accumulated Givens rotations in workspace. * N2NB denotes the number of 2*NNB-by-2*NNB factors * NBLST denotes the (possibly smaller) order of the last * factor. * N2NB = ( IHI-JCOL-1 ) / NNB - 1 NBLST = IHI - JCOL - N2NB*NNB CALL DLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, NBLST ) PW = NBLST * NBLST + 1 DO I = 1, N2NB CALL DLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, $ WORK( PW ), 2*NNB ) PW = PW + 4*NNB*NNB END DO * * Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. * DO J = JCOL, JCOL+NNB-1 * * Reduce Jth column of A. Store cosines and sines in Jth * column of A and B, respectively. * DO I = IHI, J+2, -1 TEMP = A( I-1, J ) CALL DLARTG( TEMP, A( I, J ), C, S, A( I-1, J ) ) A( I, J ) = C B( I, J ) = S END DO * * Accumulate Givens rotations into workspace array. * PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 LEN = 2 + J - JCOL JROW = J + N2NB*NNB + 2 DO I = IHI, JROW, -1 C = A( I, J ) S = B( I, J ) DO JJ = PPW, PPW+LEN-1 TEMP = WORK( JJ + NBLST ) WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) WORK( JJ ) = S*TEMP + C*WORK( JJ ) END DO LEN = LEN + 1 PPW = PPW - NBLST - 1 END DO * PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB J0 = JROW - NNB DO JROW = J0, J+2, -NNB PPW = PPWO LEN = 2 + J - JCOL DO I = JROW+NNB-1, JROW, -1 C = A( I, J ) S = B( I, J ) DO JJ = PPW, PPW+LEN-1 TEMP = WORK( JJ + 2*NNB ) WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) WORK( JJ ) = S*TEMP + C*WORK( JJ ) END DO LEN = LEN + 1 PPW = PPW - 2*NNB - 1 END DO PPWO = PPWO + 4*NNB*NNB END DO * * TOP denotes the number of top rows in A and B that will * not be updated during the next steps. * IF( JCOL.LE.2 ) THEN TOP = 0 ELSE TOP = JCOL END IF * * Propagate transformations through B and replace stored * left sines/cosines by right sines/cosines. * DO JJ = N, J+1, -1 * * Update JJth column of B. * DO I = MIN( JJ+1, IHI ), J+2, -1 C = A( I, J ) S = B( I, J ) TEMP = B( I, JJ ) B( I, JJ ) = C*TEMP - S*B( I-1, JJ ) B( I-1, JJ ) = S*TEMP + C*B( I-1, JJ ) END DO * * Annihilate B( JJ+1, JJ ). * IF( JJ.LT.IHI ) THEN TEMP = B( JJ+1, JJ+1 ) CALL DLARTG( TEMP, B( JJ+1, JJ ), C, S, $ B( JJ+1, JJ+1 ) ) B( JJ+1, JJ ) = ZERO CALL DROT( JJ-TOP, B( TOP+1, JJ+1 ), 1, $ B( TOP+1, JJ ), 1, C, S ) A( JJ+1, J ) = C B( JJ+1, J ) = -S END IF END DO * * Update A by transformations from right. * Explicit loop unrolling provides better performance * compared to DLASR. * CALL DLASR( 'Right', 'Variable', 'Backward', IHI-TOP, * $ IHI-J, A( J+2, J ), B( J+2, J ), * $ A( TOP+1, J+1 ), LDA ) * JJ = MOD( IHI-J-1, 3 ) DO I = IHI-J-3, JJ+1, -3 C = A( J+1+I, J ) S = -B( J+1+I, J ) C1 = A( J+2+I, J ) S1 = -B( J+2+I, J ) C2 = A( J+3+I, J ) S2 = -B( J+3+I, J ) * DO K = TOP+1, IHI TEMP = A( K, J+I ) TEMP1 = A( K, J+I+1 ) TEMP2 = A( K, J+I+2 ) TEMP3 = A( K, J+I+3 ) A( K, J+I+3 ) = C2*TEMP3 + S2*TEMP2 TEMP2 = -S2*TEMP3 + C2*TEMP2 A( K, J+I+2 ) = C1*TEMP2 + S1*TEMP1 TEMP1 = -S1*TEMP2 + C1*TEMP1 A( K, J+I+1 ) = C*TEMP1 + S*TEMP A( K, J+I ) = -S*TEMP1 + C*TEMP END DO END DO * IF( JJ.GT.0 ) THEN DO I = JJ, 1, -1 CALL DROT( IHI-TOP, A( TOP+1, J+I+1 ), 1, $ A( TOP+1, J+I ), 1, A( J+1+I, J ), $ -B( J+1+I, J ) ) END DO END IF * * Update (J+1)th column of A by transformations from left. * IF ( J .LT. JCOL + NNB - 1 ) THEN LEN = 1 + J - JCOL * * Multiply with the trailing accumulated orthogonal * matrix, which takes the form * * [ U11 U12 ] * U = [ ], * [ U21 U22 ] * * where U21 is a LEN-by-LEN matrix and U12 is lower * triangular. * JROW = IHI - NBLST + 1 CALL DGEMV( 'Transpose', NBLST, LEN, ONE, WORK, $ NBLST, A( JROW, J+1 ), 1, ZERO, $ WORK( PW ), 1 ) PPW = PW + LEN DO I = JROW, JROW+NBLST-LEN-1 WORK( PPW ) = A( I, J+1 ) PPW = PPW + 1 END DO CALL DTRMV( 'Lower', 'Transpose', 'Non-unit', $ NBLST-LEN, WORK( LEN*NBLST + 1 ), NBLST, $ WORK( PW+LEN ), 1 ) CALL DGEMV( 'Transpose', LEN, NBLST-LEN, ONE, $ WORK( (LEN+1)*NBLST - LEN + 1 ), NBLST, $ A( JROW+NBLST-LEN, J+1 ), 1, ONE, $ WORK( PW+LEN ), 1 ) PPW = PW DO I = JROW, JROW+NBLST-1 A( I, J+1 ) = WORK( PPW ) PPW = PPW + 1 END DO * * Multiply with the other accumulated orthogonal * matrices, which take the form * * [ U11 U12 0 ] * [ ] * U = [ U21 U22 0 ], * [ ] * [ 0 0 I ] * * where I denotes the (NNB-LEN)-by-(NNB-LEN) identity * matrix, U21 is a LEN-by-LEN upper triangular matrix * and U12 is an NNB-by-NNB lower triangular matrix. * PPWO = 1 + NBLST*NBLST J0 = JROW - NNB DO JROW = J0, JCOL+1, -NNB PPW = PW + LEN DO I = JROW, JROW+NNB-1 WORK( PPW ) = A( I, J+1 ) PPW = PPW + 1 END DO PPW = PW DO I = JROW+NNB, JROW+NNB+LEN-1 WORK( PPW ) = A( I, J+1 ) PPW = PPW + 1 END DO CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', LEN, $ WORK( PPWO + NNB ), 2*NNB, WORK( PW ), $ 1 ) CALL DTRMV( 'Lower', 'Transpose', 'Non-unit', NNB, $ WORK( PPWO + 2*LEN*NNB ), $ 2*NNB, WORK( PW + LEN ), 1 ) CALL DGEMV( 'Transpose', NNB, LEN, ONE, $ WORK( PPWO ), 2*NNB, A( JROW, J+1 ), 1, $ ONE, WORK( PW ), 1 ) CALL DGEMV( 'Transpose', LEN, NNB, ONE, $ WORK( PPWO + 2*LEN*NNB + NNB ), 2*NNB, $ A( JROW+NNB, J+1 ), 1, ONE, $ WORK( PW+LEN ), 1 ) PPW = PW DO I = JROW, JROW+LEN+NNB-1 A( I, J+1 ) = WORK( PPW ) PPW = PPW + 1 END DO PPWO = PPWO + 4*NNB*NNB END DO END IF END DO * * Apply accumulated orthogonal matrices to A. * COLA = N - JCOL - NNB + 1 J = IHI - NBLST + 1 CALL DGEMM( 'Transpose', 'No Transpose', NBLST, $ COLA, NBLST, ONE, WORK, NBLST, $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), $ NBLST ) CALL DLACPY( 'All', NBLST, COLA, WORK( PW ), NBLST, $ A( J, JCOL+NNB ), LDA ) PPWO = NBLST*NBLST + 1 J0 = J - NNB DO J = J0, JCOL+1, -NNB IF ( BLK22 ) THEN * * Exploit the structure of * * [ U11 U12 ] * U = [ ] * [ U21 U22 ], * * where all blocks are NNB-by-NNB, U21 is upper * triangular and U12 is lower triangular. * CALL DORM22( 'Left', 'Transpose', 2*NNB, COLA, NNB, $ NNB, WORK( PPWO ), 2*NNB, $ A( J, JCOL+NNB ), LDA, WORK( PW ), $ LWORK-PW+1, IERR ) ELSE * * Ignore the structure of U. * CALL DGEMM( 'Transpose', 'No Transpose', 2*NNB, $ COLA, 2*NNB, ONE, WORK( PPWO ), 2*NNB, $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), $ 2*NNB ) CALL DLACPY( 'All', 2*NNB, COLA, WORK( PW ), 2*NNB, $ A( J, JCOL+NNB ), LDA ) END IF PPWO = PPWO + 4*NNB*NNB END DO * * Apply accumulated orthogonal matrices to Q. * IF( WANTQ ) THEN J = IHI - NBLST + 1 IF ( INITQ ) THEN TOPQ = MAX( 2, J - JCOL + 1 ) NH = IHI - TOPQ + 1 ELSE TOPQ = 1 NH = N END IF CALL DGEMM( 'No Transpose', 'No Transpose', NH, $ NBLST, NBLST, ONE, Q( TOPQ, J ), LDQ, $ WORK, NBLST, ZERO, WORK( PW ), NH ) CALL DLACPY( 'All', NH, NBLST, WORK( PW ), NH, $ Q( TOPQ, J ), LDQ ) PPWO = NBLST*NBLST + 1 J0 = J - NNB DO J = J0, JCOL+1, -NNB IF ( INITQ ) THEN TOPQ = MAX( 2, J - JCOL + 1 ) NH = IHI - TOPQ + 1 END IF IF ( BLK22 ) THEN * * Exploit the structure of U. * CALL DORM22( 'Right', 'No Transpose', NH, 2*NNB, $ NNB, NNB, WORK( PPWO ), 2*NNB, $ Q( TOPQ, J ), LDQ, WORK( PW ), $ LWORK-PW+1, IERR ) ELSE * * Ignore the structure of U. * CALL DGEMM( 'No Transpose', 'No Transpose', NH, $ 2*NNB, 2*NNB, ONE, Q( TOPQ, J ), LDQ, $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), $ NH ) CALL DLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, $ Q( TOPQ, J ), LDQ ) END IF PPWO = PPWO + 4*NNB*NNB END DO END IF * * Accumulate right Givens rotations if required. * IF ( WANTZ .OR. TOP.GT.0 ) THEN * * Initialize small orthogonal factors that will hold the * accumulated Givens rotations in workspace. * CALL DLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, $ NBLST ) PW = NBLST * NBLST + 1 DO I = 1, N2NB CALL DLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, $ WORK( PW ), 2*NNB ) PW = PW + 4*NNB*NNB END DO * * Accumulate Givens rotations into workspace array. * DO J = JCOL, JCOL+NNB-1 PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 LEN = 2 + J - JCOL JROW = J + N2NB*NNB + 2 DO I = IHI, JROW, -1 C = A( I, J ) A( I, J ) = ZERO S = B( I, J ) B( I, J ) = ZERO DO JJ = PPW, PPW+LEN-1 TEMP = WORK( JJ + NBLST ) WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) WORK( JJ ) = S*TEMP + C*WORK( JJ ) END DO LEN = LEN + 1 PPW = PPW - NBLST - 1 END DO * PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB J0 = JROW - NNB DO JROW = J0, J+2, -NNB PPW = PPWO LEN = 2 + J - JCOL DO I = JROW+NNB-1, JROW, -1 C = A( I, J ) A( I, J ) = ZERO S = B( I, J ) B( I, J ) = ZERO DO JJ = PPW, PPW+LEN-1 TEMP = WORK( JJ + 2*NNB ) WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) WORK( JJ ) = S*TEMP + C*WORK( JJ ) END DO LEN = LEN + 1 PPW = PPW - 2*NNB - 1 END DO PPWO = PPWO + 4*NNB*NNB END DO END DO ELSE * CALL DLASET( 'Lower', IHI - JCOL - 1, NNB, ZERO, ZERO, $ A( JCOL + 2, JCOL ), LDA ) CALL DLASET( 'Lower', IHI - JCOL - 1, NNB, ZERO, ZERO, $ B( JCOL + 2, JCOL ), LDB ) END IF * * Apply accumulated orthogonal matrices to A and B. * IF ( TOP.GT.0 ) THEN J = IHI - NBLST + 1 CALL DGEMM( 'No Transpose', 'No Transpose', TOP, $ NBLST, NBLST, ONE, A( 1, J ), LDA, $ WORK, NBLST, ZERO, WORK( PW ), TOP ) CALL DLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, $ A( 1, J ), LDA ) PPWO = NBLST*NBLST + 1 J0 = J - NNB DO J = J0, JCOL+1, -NNB IF ( BLK22 ) THEN * * Exploit the structure of U. * CALL DORM22( 'Right', 'No Transpose', TOP, 2*NNB, $ NNB, NNB, WORK( PPWO ), 2*NNB, $ A( 1, J ), LDA, WORK( PW ), $ LWORK-PW+1, IERR ) ELSE * * Ignore the structure of U. * CALL DGEMM( 'No Transpose', 'No Transpose', TOP, $ 2*NNB, 2*NNB, ONE, A( 1, J ), LDA, $ WORK( PPWO ), 2*NNB, ZERO, $ WORK( PW ), TOP ) CALL DLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, $ A( 1, J ), LDA ) END IF PPWO = PPWO + 4*NNB*NNB END DO * J = IHI - NBLST + 1 CALL DGEMM( 'No Transpose', 'No Transpose', TOP, $ NBLST, NBLST, ONE, B( 1, J ), LDB, $ WORK, NBLST, ZERO, WORK( PW ), TOP ) CALL DLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, $ B( 1, J ), LDB ) PPWO = NBLST*NBLST + 1 J0 = J - NNB DO J = J0, JCOL+1, -NNB IF ( BLK22 ) THEN * * Exploit the structure of U. * CALL DORM22( 'Right', 'No Transpose', TOP, 2*NNB, $ NNB, NNB, WORK( PPWO ), 2*NNB, $ B( 1, J ), LDB, WORK( PW ), $ LWORK-PW+1, IERR ) ELSE * * Ignore the structure of U. * CALL DGEMM( 'No Transpose', 'No Transpose', TOP, $ 2*NNB, 2*NNB, ONE, B( 1, J ), LDB, $ WORK( PPWO ), 2*NNB, ZERO, $ WORK( PW ), TOP ) CALL DLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, $ B( 1, J ), LDB ) END IF PPWO = PPWO + 4*NNB*NNB END DO END IF * * Apply accumulated orthogonal matrices to Z. * IF( WANTZ ) THEN J = IHI - NBLST + 1 IF ( INITQ ) THEN TOPQ = MAX( 2, J - JCOL + 1 ) NH = IHI - TOPQ + 1 ELSE TOPQ = 1 NH = N END IF CALL DGEMM( 'No Transpose', 'No Transpose', NH, $ NBLST, NBLST, ONE, Z( TOPQ, J ), LDZ, $ WORK, NBLST, ZERO, WORK( PW ), NH ) CALL DLACPY( 'All', NH, NBLST, WORK( PW ), NH, $ Z( TOPQ, J ), LDZ ) PPWO = NBLST*NBLST + 1 J0 = J - NNB DO J = J0, JCOL+1, -NNB IF ( INITQ ) THEN TOPQ = MAX( 2, J - JCOL + 1 ) NH = IHI - TOPQ + 1 END IF IF ( BLK22 ) THEN * * Exploit the structure of U. * CALL DORM22( 'Right', 'No Transpose', NH, 2*NNB, $ NNB, NNB, WORK( PPWO ), 2*NNB, $ Z( TOPQ, J ), LDZ, WORK( PW ), $ LWORK-PW+1, IERR ) ELSE * * Ignore the structure of U. * CALL DGEMM( 'No Transpose', 'No Transpose', NH, $ 2*NNB, 2*NNB, ONE, Z( TOPQ, J ), LDZ, $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), $ NH ) CALL DLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, $ Z( TOPQ, J ), LDZ ) END IF PPWO = PPWO + 4*NNB*NNB END DO END IF END DO END IF * * Use unblocked code to reduce the rest of the matrix * Avoid re-initialization of modified Q and Z. * COMPQ2 = COMPQ COMPZ2 = COMPZ IF ( JCOL.NE.ILO ) THEN IF ( WANTQ ) $ COMPQ2 = 'V' IF ( WANTZ ) $ COMPZ2 = 'V' END IF * IF ( JCOL.LT.IHI ) $ CALL DGGHRD( COMPQ2, COMPZ2, N, JCOL, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, IERR ) WORK( 1 ) = DBLE( LWKOPT ) * RETURN * * End of DGGHD3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dgghrd.f000066400000000000000000000250741522610125300262210ustar00rootroot00000000000000*> \brief \b DGGHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGHRD reduces a pair of real matrices (A,B) to generalized upper *> Hessenberg form using orthogonal transformations, where A is a *> general matrix and B is upper triangular. The form of the *> generalized eigenvalue problem is *> A*x = lambda*B*x, *> and B is typically made upper triangular by computing its QR *> factorization and moving the orthogonal matrix Q to the left side *> of the equation. *> *> This subroutine simultaneously reduces A to a Hessenberg matrix H: *> Q**T*A*Z = H *> and transforms B to another upper triangular matrix T: *> Q**T*B*Z = T *> in order to reduce the problem to its standard form *> H*y = lambda*T*y *> where y = Z**T*x. *> *> The orthogonal matrices Q and Z are determined as products of Givens *> rotations. They may either be formed explicitly, or they may be *> postmultiplied into input matrices Q1 and Z1, so that *> *> Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T *> *> Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T *> *> If Q1 is the orthogonal matrix from the QR factorization of B in the *> original equation A*x = lambda*B*x, then DGGHRD reduces the original *> problem to generalized Hessenberg form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': do not compute Q; *> = 'I': Q is initialized to the unit matrix, and the *> orthogonal matrix Q is returned; *> = 'V': Q must contain an orthogonal matrix Q1 on entry, *> and the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': do not compute Z; *> = 'I': Z is initialized to the unit matrix, and the *> orthogonal matrix Z is returned; *> = 'V': Z must contain an orthogonal matrix Z1 on entry, *> and the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI mark the rows and columns of A which are to be *> reduced. It is assumed that A is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are *> normally set by a previous call to DGGBAL; otherwise they *> should be set to 1 and N respectively. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, and the *> rest is set to zero. *> \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 N-by-N upper triangular matrix B. *> On exit, the upper triangular matrix T = Q**T B Z. The *> elements below the diagonal are set to zero. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the orthogonal matrix Q1, *> typically from the QR factorization of B. *> On exit, if COMPQ='I', the orthogonal matrix Q, and if *> COMPQ = 'V', the product Q1*Q. *> Not referenced if COMPQ='N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the orthogonal matrix Z1. *> On exit, if COMPZ='I', the orthogonal matrix Z, and if *> COMPZ = 'V', the product Z1*Z. *> Not referenced if COMPZ='N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. *> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. *> \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 *> *> This routine reduces A to Hessenberg and B to triangular form by *> an unblocked reduction, as described in _Matrix_Computations_, *> by Golub and Van Loan (Johns Hopkins Press.) *> \endverbatim *> * ===================================================================== SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, 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 COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ILQ, ILZ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW DOUBLE PRECISION C, S, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARTG, DLASET, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode COMPQ * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * * Decode COMPZ * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Test the input parameters. * INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGHRD', -INFO ) RETURN END IF * * Initialize Q and Z if desired. * IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Zero out lower triangle of B * DO 20 JCOL = 1, N - 1 DO 10 JROW = JCOL + 1, N B( JROW, JCOL ) = ZERO 10 CONTINUE 20 CONTINUE * * Reduce A and B * DO 40 JCOL = ILO, IHI - 2 * DO 30 JROW = IHI, JCOL + 2, -1 * * Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) * TEMP = A( JROW-1, JCOL ) CALL DLARTG( TEMP, A( JROW, JCOL ), C, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = ZERO CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, C, S ) CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, $ B( JROW, JROW-1 ), LDB, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S ) * * Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) * TEMP = B( JROW, JROW ) CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S, $ B( JROW, JROW ) ) B( JROW, JROW-1 ) = ZERO CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, $ S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) 30 CONTINUE 40 CONTINUE * RETURN * * End of DGGHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dhgeqz.f000066400000000000000000001304311522610125300262360ustar00rootroot00000000000000*> \brief \b DHGEQZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DHGEQZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), * $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DHGEQZ computes the eigenvalues of a real matrix pair (H,T), *> where H is an upper Hessenberg matrix and T is upper triangular, *> using the double-shift QZ method. *> Matrix pairs of this type are produced by the reduction to *> generalized upper Hessenberg form of a real matrix pair (A,B): *> *> A = Q1*H*Z1**T, B = Q1*T*Z1**T, *> *> as computed by DGGHRD. *> *> 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. *> *> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair *> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of *> eigenvalues. *> *> Additionally, the 2-by-2 upper triangular diagonal blocks of P *> corresponding to 2-by-2 blocks of S are reduced to positive diagonal *> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, *> P(j,j) > 0, and P(j+1,j+1) > 0. *> *> Optionally, the orthogonal matrix Q from the generalized Schur *> factorization may be postmultiplied into an input matrix Q1, and the *> orthogonal matrix Z may be postmultiplied into an input matrix Z1. *> If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced *> the matrix pair (A,B) to generalized upper Hessenberg form, then the *> output matrices Q1*Q and Z1*Z are the orthogonal factors from the *> 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. *> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the *> generalized nonsymmetric eigenvalue problem (GNEP) *> A*x = lambda*B*x *> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the *> alternate form of the GNEP *> mu*A*y = B*y. *> Real eigenvalues can be read directly from the generalized Schur *> form: *> alpha = S(i,i), beta = P(i,i). *> *> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix *> Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), *> pp. 241--256. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; *> = 'S': Compute eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': Left Schur vectors (Q) are not computed; *> = 'I': Q is initialized to the unit matrix and the matrix Q *> of left Schur vectors of (H,T) is returned; *> = 'V': Q must contain an orthogonal matrix Q1 on entry and *> the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Right Schur vectors (Z) are not computed; *> = 'I': Z is initialized to the unit matrix and the matrix Z *> of right Schur vectors of (H,T) is returned; *> = 'V': Z must contain an orthogonal matrix Z1 on entry and *> the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices H, T, Q, and Z. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI mark the rows and columns of H which are in *> Hessenberg form. It is assumed that A is already upper *> triangular in rows and columns 1:ILO-1 and IHI+1:N. *> If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH, N) *> On entry, the N-by-N upper Hessenberg matrix H. *> On exit, if JOB = 'S', H contains the upper quasi-triangular *> matrix S from the generalized Schur factorization. *> If JOB = 'E', the diagonal blocks of H match those of S, but *> the rest of H is unspecified. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max( 1, N ). *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT, N) *> On entry, the N-by-N upper triangular matrix T. *> On exit, if JOB = 'S', T contains the upper triangular *> matrix P from the generalized Schur factorization; *> 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S *> are reduced to positive diagonal form, i.e., if H(j+1,j) is *> non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and *> T(j+1,j+1) > 0. *> If JOB = 'E', the diagonal blocks of T match those of P, but *> the rest of T is unspecified. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max( 1, N ). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> The imaginary parts of each scalar alpha defining an *> eigenvalue of GNEP. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). *> \endverbatim *> *> \param[out] BETA *> \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 *> mu = beta/alpha. Since either lambda or mu may overflow, *> they should not, in general, be computed. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in *> the reduction of (A,B) to generalized Hessenberg form. *> 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 COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If COMPQ='V' or 'I', then LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in *> the reduction of (A,B) to generalized Hessenberg form. *> On exit, if COMPZ = 'I', the orthogonal matrix of *> right Schur vectors of (H,T), and if COMPZ = 'V', the *> orthogonal matrix of right Schur vectors of (A,B). *> Not referenced if COMPZ = 'N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If COMPZ='V' or 'I', then LDZ >= 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 dimension of the array WORK. LWORK >= max(1,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 *> = 1,...,N: the QZ iteration did not converge. (H,T) is not *> in Schur form, but ALPHAR(i), ALPHAI(i), and *> BETA(i), i=INFO+1,...,N should be correct. *> = N+1,...,2*N: the shift calculation failed. (H,T) is not *> in Schur form, but ALPHAR(i), ALPHAI(i), and *> BETA(i), i=INFO-N+1,...,N should be correct. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> Iteration counters: *> *> JITER -- counts iterations. *> IITER -- counts iterations run since ILAST was last *> changed. This is therefore reset only when a 1-by-1 or *> 2-by-2 block deflates off the bottom. *> \endverbatim *> * ===================================================================== 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.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 COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * $ SAFETY = 1.0E+0 ) DOUBLE PRECISION HALF, ZERO, ONE, SAFETY PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, $ SAFETY = 1.0D+2 ) * .. * .. Local Scalars .. LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, $ LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3 * .. * .. External Subroutines .. EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Decode JOB, COMPQ, COMPZ * IF( LSAME( JOB, 'E' ) ) THEN ILSCHR = .FALSE. ISCHUR = 1 ELSE IF( LSAME( JOB, 'S' ) ) THEN ILSCHR = .TRUE. ISCHUR = 2 ELSE ISCHUR = 0 END IF * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Check Argument Values * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.EQ.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 ) THEN INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE IF( LDH.LT.N ) THEN INFO = -8 ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -17 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DHGEQZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = DBLE( 1 ) RETURN END IF * * Initialize Q and Z * IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Machine Constants * IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) BSCALE = ONE / MAX( SAFMIN, BNORM ) * * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J H( JR, J ) = -H( JR, J ) T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE H( J, J ) = -H( J, J ) T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N Z( JR, J ) = -Z( JR, J ) 20 CONTINUE END IF END IF ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps * IF( IHI.LT.ILO ) $ GO TO 380 * * MAIN QZ ITERATION LOOP * * Initialize dynamic indices * * Eigenvalues ILAST+1:N have been found. * Column operations modify rows IFRSTM:whatever. * Row operations modify columns whatever:ILASTM. * * If only eigenvalues are being computed, then * IFRSTM is the row of the last splitting row above row ILAST; * this is always at least ILO. * IITER counts iterations since the last eigenvalue was found, * to tell when to use an extraordinary shift. * MAXIT is the maximum number of QZ sweeps allowed. * ILAST = IHI IF( ILSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ESHIFT = ZERO MAXIT = 30*( IHI-ILO+1 ) * DO 360 JITER = 1, MAXIT * * Split the matrix if possible. * * Two tests: * 1: H(j,j-1)=0 or j=ILO * 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * * Special case: j=ILAST * GO TO 80 ELSE IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN T( ILAST, ILAST ) = ZERO GO TO 70 END IF * * General case: j unfl ) * __ * (sA - wB) ( CZ -SZ ) * ( SZ CZ ) * C11R = S1*A11 - WR*B11 C11I = -WI*B11 C12 = S1*A12 C21 = S1*A21 C22R = S1*A22 - WR*B22 C22I = -WI*B22 * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN T1 = DLAPY3( C12, C11R, C11I ) CZ = C12 / T1 SZR = -C11R / T1 SZI = -C11I / T1 ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN CZ = ZERO SZR = ONE SZI = ZERO ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ T1 = DLAPY2( CZ, C21 ) CZ = CZ / T1 SZR = -C21*TEMPR / T1 SZI = C21*TEMPI / T1 END IF END IF * * Compute Givens rotation on left * * ( CQ SQ ) * ( __ ) A or B * ( -SQ CQ ) * AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) BN = ABS( B11 ) + ABS( B22 ) WABS = ABS( WR ) + ABS( WI ) IF( S1*AN.GT.WABS*BN ) THEN CQ = CZ*B11 SQR = SZR*B22 SQI = -SZI*B22 ELSE A1R = CZ*A11 + SZR*A12 A1I = SZI*A12 A2R = CZ*A21 + SZR*A22 A2I = SZI*A22 CQ = DLAPY2( A1R, A1I ) IF( CQ.LE.SAFMIN ) THEN CQ = ZERO SQR = ONE SQI = ZERO ELSE TEMPR = A1R / CQ TEMPI = A1I / CQ SQR = TEMPR*A2R + TEMPI*A2I SQI = TEMPI*A2R - TEMPR*A2I END IF END IF T1 = DLAPY3( CQ, SQR, SQI ) CQ = CQ / T1 SQR = SQR / T1 SQI = SQI / T1 * * Compute diagonal elements of QBZ * TEMPR = SQR*SZR - SQI*SZI TEMPI = SQR*SZI + SQI*SZR B1R = CQ*CZ*B11 + TEMPR*B22 B1I = TEMPI*B22 B1A = DLAPY2( B1R, B1I ) B2R = CQ*CZ*B22 + TEMPR*B11 B2I = -TEMPI*B11 B2A = DLAPY2( B2R, B2I ) * * Normalize so beta > 0, and Im( alpha1 ) > 0 * BETA( ILAST-1 ) = B1A BETA( ILAST ) = B2A ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV ALPHAR( ILAST ) = ( WR*B2A )*S1INV ALPHAI( ILAST ) = -( WI*B2A )*S1INV * * Step 3: Go to next block -- exit if finished. * ILAST = IFIRST - 1 IF( ILAST.LT.ILO ) $ GO TO 380 * * Reset counters * IITER = 0 ESHIFT = ZERO IF( .NOT.ILSCHR ) THEN ILASTM = ILAST IF( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF GO TO 350 ELSE * * Usual case: 3x3 or larger block, using Francis implicit * double-shift * * 2 * Eigenvalue equation is w - c w + d = 0, * * -1 2 -1 * so compute 1st column of (A B ) - c A B + d * using the formula in QZIT (from EISPACK) * * We assume that the block is at least 3x3 * AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / $ ( BSCALE*T( ILAST, ILAST ) ) AD22 = ( ASCALE*H( ILAST, ILAST ) ) / $ ( BSCALE*T( ILAST, ILAST ) ) U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / $ ( BSCALE*T( IFIRST, IFIRST ) ) AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / $ ( BSCALE*T( IFIRST, IFIRST ) ) AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- $ ( AD22-AD11L )+AD21*U12 )*AD21L V( 3 ) = AD32L*AD21L * ISTART = IFIRST * CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE * * Sweep * DO 290 J = ISTART, ILAST - 2 * * All but last elements: use 3x3 Householder transforms. * * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN V( 1 ) = H( J, J-1 ) V( 2 ) = H( J+1, J-1 ) V( 3 ) = H( J+2, J-1 ) * CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE H( J+1, J-1 ) = ZERO H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* $ H( J+2, JC ) ) H( J, JC ) = H( J, JC ) - TEMP H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* $ T( J+2, JC ) ) T( J, JC ) = T( J, JC ) - TEMP2 T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* $ Q( JR, J+2 ) ) Q( JR, J ) = Q( JR, J ) - TEMP Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) 240 CONTINUE END IF * * Zero j-th column of B (see DLAGBC for details) * * Swap rows to pivot * ILPIVT = .FALSE. TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN W11 = T( J+1, J+1 ) W21 = T( J+2, J+1 ) W12 = T( J+1, J+2 ) W22 = T( J+2, J+2 ) U1 = T( J+1, J ) U2 = T( J+2, J ) ELSE W21 = T( J+1, J+1 ) W11 = T( J+2, J+1 ) W22 = T( J+1, J+2 ) W12 = T( J+2, J+2 ) U2 = T( J+1, J ) U1 = T( J+2, J ) END IF * * Swap columns if nec. * IF( ABS( W12 ).GT.ABS( W11 ) ) THEN ILPIVT = .TRUE. TEMP = W12 TEMP2 = W22 W12 = W11 W22 = W21 W11 = TEMP W21 = TEMP2 END IF * * LU-factor * TEMP = W21 / W11 U2 = U2 - TEMP*U1 W22 = W22 - TEMP*W12 W21 = ZERO * * Compute SCALE * SCALE = ONE IF( ABS( W22 ).LT.SAFMIN ) THEN SCALE = ZERO U2 = ONE U1 = -W12 / W11 GO TO 250 END IF IF( ABS( W22 ).LT.ABS( U2 ) ) $ SCALE = ABS( W22 / U2 ) IF( ABS( W11 ).LT.ABS( U1 ) ) $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) * * Solve * U2 = ( SCALE*U2 ) / W22 U1 = ( SCALE*U1-W12*U2 ) / W11 * 250 CONTINUE IF( ILPIVT ) THEN TEMP = U2 U2 = U1 U1 = TEMP END IF * * Compute Householder Vector * T1 = SQRT( SCALE**2+U1**2+U2**2 ) TAU = ONE + SCALE / T1 VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 * * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* $ H( JR, J+2 ) ) H( JR, J ) = H( JR, J ) - TEMP H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* $ T( JR, J+2 ) ) T( JR, J ) = T( JR, J ) - TEMP T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* $ Z( JR, J+2 ) ) Z( JR, J ) = Z( JR, J ) - TEMP Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF T( J+1, J ) = ZERO T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations * * Rotations from the left * J = ILAST - 1 TEMP = H( J, J-1 ) CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM TEMP = C*H( J, JC ) + S*H( J+1, JC ) H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) H( J, JC ) = TEMP TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) Q( JR, J ) = TEMP 310 CONTINUE END IF * * Rotations from the right. * TEMP = T( J+1, J+1 ) CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST TEMP = C*H( JR, J+1 ) + S*H( JR, J ) H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 TEMP = C*T( JR, J+1 ) + S*T( JR, J ) T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) Z( JR, J+1 ) = TEMP 340 CONTINUE END IF * * End of Double-Shift code * END IF * GO TO 350 * * End of iteration loop * 350 CONTINUE 360 CONTINUE * * Drop-through = non-convergence * INFO = ILAST GO TO 420 * * Successful completion of all QZ steps * 380 CONTINUE * * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J H( JR, J ) = -H( JR, J ) T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE H( J, J ) = -H( J, J ) T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N Z( JR, J ) = -Z( JR, J ) 400 CONTINUE END IF END IF ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination * INFO = 0 * * Exit (other than argument error) -- return optimal workspace size * 420 CONTINUE WORK( 1 ) = DBLE( N ) RETURN * * End of DHGEQZ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dhseqr.f000066400000000000000000000444051522610125300262470ustar00rootroot00000000000000*> \brief \b DHSEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DHSEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DHSEQR computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**T, where T is an upper quasi-triangular matrix (the *> Schur form), and Z is the orthogonal matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input orthogonal *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': compute eigenvalues only; *> = 'S': compute eigenvalues and the Schur form T. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': no Schur vectors are computed; *> = 'I': Z is initialized to the unit matrix and the matrix Z *> of Schur vectors of H is returned; *> = 'V': Z must contain an orthogonal matrix Q on entry, and *> the product Q*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to DGEBAL, and then passed to ZGEHRD *> when the matrix output by DGEBAL is reduced to Hessenberg *> form. Otherwise ILO and IHI should be set to 1 and N *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and JOB = 'S', then H contains the *> upper quasi-triangular matrix T from the Schur decomposition *> (the Schur form); 2-by-2 diagonal blocks (corresponding to *> complex conjugate pairs of eigenvalues) are returned in *> standard form, with H(i,i) = H(i+1,i+1) and *> H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the *> contents of H are unspecified on exit. (The output value of *> H when INFO.GT.0 is given under the description of INFO *> below.) *> *> Unlike earlier versions of DHSEQR, this subroutine may *> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 *> or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> *> The real and imaginary parts, respectively, of the computed *> eigenvalues. If two eigenvalues are computed as a complex *> conjugate pair, they are stored in consecutive elements of *> WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and *> WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in *> the same order as on the diagonal of the Schur form returned *> in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 *> diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and *> WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> If COMPZ = 'N', Z is not referenced. *> If COMPZ = 'I', on entry Z need not be set and on exit, *> if INFO = 0, Z contains the orthogonal matrix Z of the Schur *> vectors of H. If COMPZ = 'V', on entry Z must contain an *> N-by-N matrix Q, which is assumed to be equal to the unit *> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, *> if INFO = 0, Z contains Q*Z. *> Normally Q is the orthogonal matrix generated by DORGHR *> after the call to DGEHRD which formed the Hessenberg matrix *> H. (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if COMPZ = 'I' or *> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient and delivers very good and sometimes *> optimal performance. However, LWORK as large as 11*N *> may be required for optimal performance. A workspace *> query is recommended to determine the optimal workspace *> size. *> *> If LWORK = -1, then DHSEQR does a workspace query. *> In this case, DHSEQR checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .LT. 0: if INFO = -i, the i-th argument had an illegal *> value *> .GT. 0: if INFO = i, DHSEQR failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and JOB = 'E', then on exit, the *> remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and JOB = 'S', then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is an orthogonal matrix. The final *> value of H is upper Hessenberg and quasi-triangular *> in rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and COMPZ = 'V', then on exit *> *> (final value of Z) = (initial value of Z)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'I', then on exit *> (final value of Z) = U *> where U is the orthogonal matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'N', then Z is not *> accessed. *> \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 Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> Default values supplied by *> ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). *> It is suggested that these defaults be adjusted in order *> to attain best performance in each particular *> computational environment. *> *> ISPEC=12: The DLAHQR vs DLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> ISPEC=13: Recommended deflation window size. *> This depends on ILO, IHI and NS. NS is the *> number of simultaneous shifts returned *> by ILAENV(ISPEC=15). (See ISPEC=15 below.) *> The default for (IHI-ILO+1).LE.500 is NS. *> The default for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> ISPEC=14: Nibble crossover point. (See IPARMQ for *> details.) Default: 14% of deflation window *> size. *> *> ISPEC=15: Number of simultaneous shifts in a multishift *> QR iteration. *> *> If IHI-ILO+1 is ... *> *> greater than ...but less ... the *> or equal to ... than default is *> *> 1 30 NS = 2(+) *> 30 60 NS = 4(+) *> 60 150 NS = 10(+) *> 150 590 NS = ** *> 590 3000 NS = 64 *> 3000 6000 NS = 128 *> 6000 infinity NS = 256 *> *> (+) By default some or all matrices of this order *> are passed to the implicit double shift routine *> DLAHQR and this parameter is ignored. See *> ISPEC=12 above and comments in IPARMQ for *> details. *> *> (**) The asterisks (**) indicate an ad-hoc *> function of N increasing from 10 to 64. *> *> ISPEC=16: Select structured matrix multiply. *> If the number of simultaneous shifts (specified *> by ISPEC=15) is less than 14, then the default *> for ISPEC=16 is 0. Otherwise the default for *> ISPEC=16 is 2. *> \endverbatim * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. * * ===================================================================== SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, 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 IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare DLAHQR failure. NL .GT. NTINY = 11 is * . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== INTEGER NL PARAMETER ( NL = 49 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Arrays .. DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. INTEGER I, KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. INTEGER ILAENV LOGICAL LSAME EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) WORK( 1 ) = DBLE( MAX( 1, N ) ) LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.NE.0 ) THEN * * ==== Quick return in case of invalid argument. ==== * CALL XERBLA( 'DHSEQR', -INFO ) RETURN * ELSE IF( N.EQ.0 ) THEN * * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ELSE IF( LQUERY ) THEN * * ==== Quick return in case of a workspace query ==== * CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, WORK, LWORK, INFO ) * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) RETURN * ELSE * * ==== copy eigenvalues isolated by DGEBAL ==== * DO 10 I = 1, ILO - 1 WR( I ) = H( I, I ) WI( I ) = ZERO 10 CONTINUE DO 20 I = IHI + 1, N WR( I ) = H( I, I ) WI( I ) = ZERO 20 CONTINUE * * ==== Initialize Z, if requested ==== * IF( INITZ ) $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * * ==== Quick return if possible ==== * IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * ==== DLAHQR/DLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== DLAQR0 for big matrices; DLAHQR for small ones ==== * IF( N.GT.NMIN ) THEN CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, WORK, LWORK, INFO ) ELSE * * ==== Small matrix ==== * CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, INFO ) * IF( INFO.GT.0 ) THEN * * ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds * . when DLAHQR fails. ==== * KBOT = INFO * IF( N.GE.NL ) THEN * * ==== Larger matrices have enough subdiagonal scratch * . space to call DLAQR0 directly. ==== * CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ELSE * * ==== Tiny matrices don't have enough subdiagonal * . scratch space to benefit from DLAQR0. Hence, * . tiny matrices must be copied into a larger * . array before calling DLAQR0. ==== * CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) HL( N+1, N ) = ZERO CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), $ NL ) CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) IF( WANTT .OR. INFO.NE.0 ) $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) END IF END IF END IF * * ==== Clear out the trash, if necessary. ==== * IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== * WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) END IF * * ==== End of DHSEQR ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/disnan.f000066400000000000000000000037051522610125300262330ustar00rootroot00000000000000*> \brief \b DISNAN tests input for NaN. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DISNAN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DISNAN( DIN ) * * .. Scalar Arguments .. * DOUBLE PRECISION DIN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. *> otherwise. To be replaced by the Fortran 2003 intrinsic in the *> future. *> \endverbatim * * Arguments: * ========== * *> \param[in] DIN *> \verbatim *> DIN is DOUBLE PRECISION *> Input to test for NaN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DISNAN( DIN ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION DIN * .. * * ===================================================================== * * .. External Functions .. LOGICAL DLAISNAN EXTERNAL DLAISNAN * .. * .. Executable Statements .. DISNAN = DLAISNAN(DIN,DIN) RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlabad.f000066400000000000000000000060151522610125300261630ustar00rootroot00000000000000*> \brief \b DLABAD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLABAD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABAD( SMALL, LARGE ) * * .. Scalar Arguments .. * DOUBLE PRECISION LARGE, SMALL * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLABAD takes as input the values computed by DLAMCH for underflow and *> overflow, and returns the square root of each of these values if the *> log of LARGE is sufficiently large. This subroutine is intended to *> identify machines with a large exponent range, such as the Crays, and *> redefine the underflow and overflow limits to be the square roots of *> the values computed by DLAMCH. This subroutine is needed because *> DLAMCH does not compensate for poor arithmetic in the upper half of *> the exponent range, as is found on a Cray. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] SMALL *> \verbatim *> SMALL is DOUBLE PRECISION *> On entry, the underflow threshold as computed by DLAMCH. *> On exit, if LOG10(LARGE) is sufficiently large, the square *> root of SMALL, otherwise unchanged. *> \endverbatim *> *> \param[in,out] LARGE *> \verbatim *> LARGE is DOUBLE PRECISION *> On entry, the overflow threshold as computed by DLAMCH. *> On exit, if LOG10(LARGE) is sufficiently large, the square *> root of LARGE, otherwise unchanged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION LARGE, SMALL * .. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000.D0 ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of DLABAD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlabrd.f000066400000000000000000000330431522610125300262050ustar00rootroot00000000000000*> \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLABRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLABRD reduces the first NB rows and columns of a real general *> m by n matrix A to upper or lower bidiagonal form by an orthogonal *> transformation Q**T * A * P, and returns the matrices X and Y which *> are needed to apply the transformation to the unreduced part of A. *> *> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower *> bidiagonal form. *> *> This is an auxiliary routine called by DGEBRD *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of leading rows and columns of A to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, the first NB rows and columns of the matrix are *> overwritten; the rest of the array is unchanged. *> If m >= n, elements on and below the diagonal in the first NB *> columns, with the array TAUQ, represent the orthogonal *> matrix Q as a product of elementary reflectors; and *> elements above the diagonal in the first NB rows, with the *> array TAUP, represent the orthogonal matrix P as a product *> of elementary reflectors. *> If m < n, elements below the diagonal in the first NB *> columns, with the array TAUQ, represent the orthogonal *> matrix Q as a product of elementary reflectors, and *> elements on and above the diagonal in the first NB rows, *> with the array TAUP, represent the orthogonal matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (NB) *> The diagonal elements of the first NB rows and columns of *> the reduced matrix. D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (NB) *> The off-diagonal elements of the first NB rows and columns of *> the reduced matrix. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NB) *> The m-by-nb matrix X required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,M). *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (LDY,NB) *> The n-by-nb matrix Y required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors. *> *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in *> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The elements of the vectors v and u together form the m-by-nb matrix *> V and the nb-by-n matrix U**T which are needed, with X and Y, to apply *> the transformation to the unreduced part of the matrix, using a block *> update of the form: A := A - V*Y**T - X*U**T. *> *> The contents of A on exit are illustrated by the following examples *> with nb = 2: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) *> ( v1 v2 a a a ) ( v1 1 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix which is unchanged, *> vi denotes an element of the vector defining H(i), and ui an element *> of the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL DGEMV, DLARFG, DSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) IF( I.LT.N ) THEN A( I, I ) = ONE * * Compute Y(i+1:n,i) * CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) * * Generate reflection P(i) to annihilate A(i,i+2:n) * CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) A( I, I+1 ) = ONE * * Compute X(i+1:m,i) * CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) * * Generate reflection P(i) to annihilate A(i,i+1:n) * CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = A( I, I ) IF( I.LT.M ) THEN A( I, I ) = ONE * * Compute X(i+1:m,i) * CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) * * Update A(i+1:m,i) * CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+2:m,i) * CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Compute Y(i+1:n,i) * CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) END IF 20 CONTINUE END IF RETURN * * End of DLABRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlacn2.f000066400000000000000000000170431522610125300261220ustar00rootroot00000000000000*> \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLACN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST * .. * .. Array Arguments .. * INTEGER ISGN( * ), ISAVE( 3 ) * DOUBLE PRECISION V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLACN2 estimates the 1-norm of a square, real matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**T * X, if KASE=2, *> and DLACN2 must be re-called with all the other parameters *> unchanged. *> \endverbatim *> *> \param[out] ISGN *> \verbatim *> ISGN is INTEGER array, dimension (N) *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to DLACN2, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**T * X. *> On the final return from DLACN2, KASE will again be 0. *> \endverbatim *> *> \param[in,out] ISAVE *> \verbatim *> ISAVE is INTEGER array, dimension (3) *> ISAVE is used to save variables between calls to DLACN2 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Originally named SONEST, dated March 16, 1988. *> *> This is a thread safe version of DLACON, which uses the array ISAVE *> in place of a SAVE statement, as follows: *> *> DLACON DLACN2 *> JUMP ISAVE(1) *> J ISAVE(2) *> ITER ISAVE(3) *> \endverbatim * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISGN( * ), ISAVE( 3 ) DOUBLE PRECISION V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, JLAST DOUBLE PRECISION ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM EXTERNAL IDAMAX, DASUM * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, NINT, SIGN * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / DBLE( N ) 10 CONTINUE KASE = 1 ISAVE( 1 ) = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) * * ................ ENTRY (ISAVE( 1 ) = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = DASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 ISAVE( 1 ) = 2 RETURN * * ................ ENTRY (ISAVE( 1 ) = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE ISAVE( 2 ) = IDAMAX( N, X, 1 ) ISAVE( 3 ) = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( ISAVE( 2 ) ) = ONE KASE = 1 ISAVE( 1 ) = 3 RETURN * * ................ ENTRY (ISAVE( 1 ) = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL DCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 ISAVE( 1 ) = 4 RETURN * * ................ ENTRY (ISAVE( 1 ) = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = ISAVE( 2 ) ISAVE( 2 ) = IDAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN ISAVE( 3 ) = ISAVE( 3 ) + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 ISAVE( 1 ) = 5 RETURN * * ................ ENTRY (ISAVE( 1 ) = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL DCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of DLACN2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlacon.f000066400000000000000000000157001522610125300262150ustar00rootroot00000000000000*> \brief \b DLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLACON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST * .. * .. Array Arguments .. * INTEGER ISGN( * ) * DOUBLE PRECISION V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLACON estimates the 1-norm of a square, real matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**T * X, if KASE=2, *> and DLACON must be re-called with all the other parameters *> unchanged. *> \endverbatim *> *> \param[out] ISGN *> \verbatim *> ISGN is INTEGER array, dimension (N) *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to DLACON, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**T * X. *> On the final return from DLACON, KASE will again be 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester. \n *> Originally named SONEST, dated March 16, 1988. * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISGN( * ) DOUBLE PRECISION V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM EXTERNAL IDAMAX, DASUM * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, NINT, SIGN * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / DBLE( N ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = DASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( J ) = ONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL DCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = J J = IDAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL DCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of DLACON * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlacpy.f000066400000000000000000000101061522610125300262240ustar00rootroot00000000000000*> \brief \b DLACPY copies all or part of one two-dimensional array to another. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLACPY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLACPY copies all or part of a two-dimensional matrix A to another *> matrix B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be copied to B. *> = 'U': Upper triangular part *> = 'L': Lower triangular part *> Otherwise: All of the matrix A *> \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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The m by n matrix A. If UPLO = 'U', only the upper triangle *> or trapezoid is accessed; if UPLO = 'L', only the lower *> triangle or trapezoid is accessed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On exit, B = A in the locations specified by UPLO. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.7.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, LDB, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE *$omp parallel private(I) *$omp do DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE *$omp end do *$omp end parallel END IF RETURN * * End of DLACPY * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dladiv.f000066400000000000000000000137061522610125300262240ustar00rootroot00000000000000*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLADIV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, D, P, Q * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLADIV performs complex division in real arithmetic *> *> a + i*b *> p + i*q = --------- *> c + i*d *> *> The algorithm is due to Michael Baudin and Robert L. Smith *> and can be found in the paper *> "A Robust Complex Division in Scilab" *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION *> The scalars a, b, c, and d in the above expression. *> \endverbatim *> *> \param[out] P *> \verbatim *> P is DOUBLE PRECISION *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION *> The scalars p and q in the above expression. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date January 2013 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION BS PARAMETER ( BS = 2.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLADIV1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * AA = A BB = B CC = C DD = D 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 S = TWO * S END IF IF( CD >= HALF*OV ) THEN CC = HALF * CC DD = HALF * DD S = HALF * S END IF IF( AB <= UN*BS/EPS ) THEN AA = AA * BE BB = BB * BE S = S / BE END IF IF( CD <= UN*BS/EPS ) THEN CC = CC * BE DD = DD * BE S = S * BE END IF IF( ABS( D ).LE.ABS( C ) ) THEN CALL DLADIV1(AA, BB, CC, DD, P, Q) ELSE CALL DLADIV1(BB, AA, DD, CC, P, Q) Q = -Q END IF P = P * S Q = Q * S * RETURN * * End of DLADIV * END *> \ingroup doubleOTHERauxiliary SUBROUTINE DLADIV1( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * * .. Local Scalars .. DOUBLE PRECISION R, T * .. * .. External Functions .. DOUBLE PRECISION DLADIV2 EXTERNAL DLADIV2 * .. * .. Executable Statements .. * R = D / C T = ONE / (C + D * R) P = DLADIV2(A, B, C, D, R, T) A = -A Q = DLADIV2(B, A, C, D, R, T) * RETURN * * End of DLADIV1 * END *> \ingroup doubleOTHERauxiliary DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, R, T * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * * .. Local Scalars .. DOUBLE PRECISION BR * .. * .. Executable Statements .. * IF( R.NE.ZERO ) THEN BR = B * R IF( BR.NE.ZERO ) THEN DLADIV2 = (A + BR) * T ELSE DLADIV2 = A * T + (B * T) * R END IF ELSE DLADIV2 = (A + D * (B / C)) * T END IF * RETURN * * End of DLADIV12 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlae2.f000066400000000000000000000113111522610125300257360ustar00rootroot00000000000000*> \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAE2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, RT1, RT2 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix *> [ A B ] *> [ B C ]. *> On return, RT1 is the eigenvalue of larger absolute value, and RT2 *> is the eigenvalue of smaller absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION *> The (1,2) and (2,1) elements of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is DOUBLE PRECISION *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is DOUBLE PRECISION *> The eigenvalue of smaller absolute value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION A, B, C, RT1, RT2 * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN * * End of DLAE2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaev2.f000066400000000000000000000140721522610125300261330ustar00rootroot00000000000000*> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix *> [ A B ] *> [ B C ]. *> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the *> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right *> eigenvector for RT1, giving the decomposition *> *> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] *> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION *> The (1,2) element and the conjugate of the (2,1) element of *> the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is DOUBLE PRECISION *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is DOUBLE PRECISION *> The eigenvalue of smaller absolute value. *> \endverbatim *> *> \param[out] CS1 *> \verbatim *> CS1 is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SN1 *> \verbatim *> SN1 is DOUBLE PRECISION *> The vector (CS1, SN1) is a unit right eigenvector for RT1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> CS1 and SN1 are accurate to a few ulps barring over/underflow. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. INTEGER SGN1, SGN2 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF * * Compute the eigenvector * IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN * * End of DLAEV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaexc.f000066400000000000000000000307761522610125300262270ustar00rootroot00000000000000*> \brief \b DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in *> an upper quasi-triangular matrix T by an orthogonal similarity *> transformation. *> *> T must be in Schur canonical form, that is, block upper triangular *> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block *> has its diagonal elemnts equal and its off-diagonal elements of *> opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> = .TRUE. : accumulate the transformation in the matrix Q; *> = .FALSE.: do not accumulate the transformation. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> canonical form. *> On exit, the updated matrix T, again 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] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ is .TRUE., the orthogonal matrix Q. *> On exit, if WANTQ is .TRUE., the updated matrix Q. *> If WANTQ is .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index of the first row of the first block T11. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The order of the first block T11. N1 = 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> The order of the second block T22. N2 = 0, 1 or 2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> = 1: the transformed matrix T would be too far from Schur *> form; the blocks are not swapped and T and Q are *> unchanged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 WANTQ INTEGER INFO, J1, LDQ, LDT, N, N1, N2 * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 1.0D+1 ) INTEGER LDD, LDX PARAMETER ( LDD = 4, LDX = 2 ) * .. * .. Local Scalars .. INTEGER IERR, J2, J3, J4, K, ND DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, $ WR1, WR2, XNORM * .. * .. Local Arrays .. DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), $ X( LDX, 2 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, $ DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN IF( J1+N1.GT.N ) $ RETURN * J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 * IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * T11 = T( J1, J1 ) T22 = T( J2, J2 ) * * Determine the transformation to perform the interchange. * CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( J3.LE.N ) $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, $ SN ) CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) * T( J1, J1 ) = T22 T( J2, J2 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * ELSE * * Swapping involves at least one 2-by-2 block. * * Copy the diagonal block of order N1+N2 to the local array D * and compute its norm. * ND = N1 + N2 CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK ) * * Compute machine-dependent threshold for test for accepting * swap. * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) * * Solve T11*X - X*T22 = scale*T12 for X. * CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, $ LDX, XNORM, IERR ) * * Swap the adjacent diagonal blocks. * K = N1 + N1 + N2 - 3 GO TO ( 10, 20, 30 )K * 10 CONTINUE * * N1 = 1, N2 = 2: generate elementary reflector H so that: * * ( scale, X11, X12 ) H = ( 0, 0, * ) * U( 1 ) = SCALE U( 2 ) = X( 1, 1 ) U( 3 ) = X( 1, 2 ) CALL DLARFG( 3, U( 3 ), U, 1, TAU ) U( 3 ) = ONE T11 = T( J1, J1 ) * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, $ 3 )-T11 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J3, J3 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 20 CONTINUE * * N1 = 2, N2 = 1: generate elementary reflector H so that: * * H ( -X11 ) = ( * ) * ( -X21 ) = ( 0 ) * ( scale ) = ( 0 ) * U( 1 ) = -X( 1, 1 ) U( 2 ) = -X( 2, 1 ) U( 3 ) = SCALE CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) U( 1 ) = ONE T33 = T( J3, J3 ) * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, $ 1 )-T33 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) * T( J1, J1 ) = T33 T( J2, J1 ) = ZERO T( J3, J1 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 30 CONTINUE * * N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so * that: * * H(2) H(1) ( -X11 -X12 ) = ( * * ) * ( -X21 -X22 ) ( 0 * ) * ( scale 0 ) ( 0 0 ) * ( 0 scale ) ( 0 0 ) * U1( 1 ) = -X( 1, 1 ) U1( 2 ) = -X( 2, 1 ) U1( 3 ) = SCALE CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) U1( 1 ) = ONE * TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) U2( 2 ) = -TEMP*U1( 3 ) U2( 3 ) = SCALE CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) U2( 1 ) = ONE * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J4, J1 ) = ZERO T( J4, J2 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) END IF * 40 CONTINUE * IF( N2.EQ.2 ) THEN * * Standardize new 2-by-2 block T11 * CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, $ CS, SN ) CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * IF( N1.EQ.2 ) THEN * * Standardize new 2-by-2 block T22 * J3 = J1 + N2 J4 = J3 + 1 CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) IF( J3+2.LE.N ) $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), $ LDT, CS, SN ) CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) END IF * END IF RETURN * * Exit with INFO = 1 if swap was rejected. * 50 CONTINUE INFO = 1 RETURN * * End of DLAEXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlag2.f000066400000000000000000000302211522610125300257410ustar00rootroot00000000000000*> \brief \b DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAG2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue *> problem A - w B, with scaling as necessary to avoid over-/underflow. *> *> The scaling factor "s" results in a modified eigenvalue equation *> *> s A - w B *> *> where s is a non-negative scaling factor chosen so that w, w B, *> and s A do not overflow and, if possible, do not underflow, either. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, 2) *> On entry, the 2 x 2 matrix A. It is assumed that its 1-norm *> is less than 1/SAFMIN. Entries less than *> sqrt(SAFMIN)*norm(A) are subject to being treated as zero. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 2. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, 2) *> On entry, the 2 x 2 upper triangular matrix B. It is *> assumed that the one-norm of B is less than 1/SAFMIN. The *> diagonals should be at least sqrt(SAFMIN) times the largest *> element of B (in absolute value); if a diagonal is smaller *> than that, then +/- sqrt(SAFMIN) will be used instead of *> that diagonal. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= 2. *> \endverbatim *> *> \param[in] SAFMIN *> \verbatim *> SAFMIN is DOUBLE PRECISION *> The smallest positive number s.t. 1/SAFMIN does not *> overflow. (This should always be DLAMCH('S') -- it is an *> argument in order to avoid having to call DLAMCH frequently.) *> \endverbatim *> *> \param[out] SCALE1 *> \verbatim *> SCALE1 is DOUBLE PRECISION *> A scaling factor used to avoid over-/underflow in the *> eigenvalue equation which defines the first eigenvalue. If *> the eigenvalues are complex, then the eigenvalues are *> ( WR1 +/- WI i ) / SCALE1 (which may lie outside the *> exponent range of the machine), SCALE1=SCALE2, and SCALE1 *> 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 threshold if the exact eigenvalue *> is sufficiently large. *> \endverbatim *> *> \param[out] SCALE2 *> \verbatim *> SCALE2 is DOUBLE PRECISION *> A scaling factor used to avoid over-/underflow in the *> eigenvalue equation which defines the second eigenvalue. If *> the eigenvalues are complex, then SCALE2=SCALE1. If the *> 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 *> threshold if the exact eigenvalue is sufficiently large. *> \endverbatim *> *> \param[out] WR1 *> \verbatim *> WR1 is DOUBLE PRECISION *> If the eigenvalue is real, then WR1 is SCALE1 times the *> eigenvalue closest to the (2,2) element of A B**(-1). If the *> eigenvalue is complex, then WR1=WR2 is SCALE1 times the real *> part of the eigenvalues. *> \endverbatim *> *> \param[out] WR2 *> \verbatim *> WR2 is DOUBLE PRECISION *> If the eigenvalue is real, then WR2 is SCALE2 times the *> other eigenvalue. If the eigenvalue is complex, then *> WR1=WR2 is SCALE1 times the real part of the eigenvalues. *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION *> If the eigenvalue is real, then WI is zero. If the *> eigenvalue is complex, then WI is SCALE1 times the imaginary *> part of the eigenvalues. WI will always be non-negative. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER LDA, LDB DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = ONE / TWO ) DOUBLE PRECISION FUZZY1 PARAMETER ( FUZZY1 = ONE+1.0D-5 ) * .. * .. Local Scalars .. DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12, $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22, $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5, $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2, $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET, $ WSCALE, WSIZE, WSMALL * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * RTMIN = SQRT( SAFMIN ) RTMAX = ONE / RTMIN SAFMAX = ONE / SAFMIN * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A11 = ASCALE*A( 1, 1 ) A21 = ASCALE*A( 2, 1 ) A12 = ASCALE*A( 1, 2 ) A22 = ASCALE*A( 2, 2 ) * * Perturb B if necessary to insure non-singularity * B11 = B( 1, 1 ) B12 = B( 1, 2 ) B22 = B( 2, 2 ) BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN ) IF( ABS( B11 ).LT.BMIN ) $ B11 = SIGN( BMIN, B11 ) IF( ABS( B22 ).LT.BMIN ) $ B22 = SIGN( BMIN, B22 ) * * Scale B * BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN ) BSIZE = MAX( ABS( B11 ), ABS( B22 ) ) BSCALE = ONE / BSIZE B11 = B11*BSCALE B12 = B12*BSCALE B22 = B22*BSCALE * * Compute larger eigenvalue by method described by C. van Loan * * ( AS is A shifted by -SHIFT*B ) * BINV11 = ONE / B11 BINV22 = ONE / B22 S1 = A11*BINV11 S2 = A22*BINV22 IF( ABS( S1 ).LE.ABS( S2 ) ) THEN AS12 = A12 - S1*B12 AS22 = A22 - S1*B22 SS = A21*( BINV11*BINV22 ) ABI22 = AS22*BINV22 - SS*B12 PP = HALF*ABI22 SHIFT = S1 ELSE AS12 = A12 - S2*B12 AS11 = A11 - S2*B11 SS = A21*( BINV11*BINV22 ) ABI22 = -SS*B12 PP = HALF*( AS11*BINV11+ABI22 ) SHIFT = S2 END IF QQ = SS*AS12 IF( ABS( PP*RTMIN ).GE.ONE ) THEN DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN R = SQRT( ABS( DISCR ) )*RTMAX ELSE IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX R = SQRT( ABS( DISCR ) )*RTMIN ELSE DISCR = PP**2 + QQ R = SQRT( ABS( DISCR ) ) END IF END IF * * 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 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 = PP - SIGN( R, PP ) WBIG = SHIFT + SUM * * Compute smaller eigenvalue * WSMALL = SHIFT + DIFF IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 ) WSMALL = WDET / WBIG END IF * * Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) * for WR1. * IF( PP.GT.ABI22 ) THEN WR1 = MIN( WBIG, WSMALL ) WR2 = MAX( WBIG, WSMALL ) ELSE WR1 = MAX( WBIG, WSMALL ) WR2 = MIN( WBIG, WSMALL ) END IF WI = ZERO ELSE * * Complex eigenvalues * WR1 = SHIFT + PP WR2 = WR1 WI = R END IF * * Further scaling to avoid underflow and overflow in computing * SCALE1 and overflow in computing w*B. * * This scale factor (WSCALE) is bounded from above using C1 and C2, * and from below using C3 and C4. * C1 implements the condition s A must never overflow. * C2 implements the condition w B must never overflow. * C3, with C2, * implement the condition that s A - w B must never overflow. * C4 implements the condition s should not underflow. * C5 implements the condition max(s,|w|) should be at least 2. * C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) ) C2 = SAFMIN*MAX( ONE, BNORM ) C3 = BSIZE*SAFMIN IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE ) ELSE C4 = ONE END IF IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN C5 = MIN( ONE, ASCALE*BSIZE ) ELSE C5 = ONE END IF * * Scale first eigenvalue * WABS = ABS( WR1 ) + ABS( WI ) WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ), $ MIN( C4, HALF*MAX( WABS, C5 ) ) ) IF( WSIZE.NE.ONE ) THEN WSCALE = ONE / WSIZE IF( WSIZE.GT.ONE ) THEN SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )* $ MIN( ASCALE, BSIZE ) ELSE SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )* $ MAX( ASCALE, BSIZE ) END IF WR1 = WR1*WSCALE IF( WI.NE.ZERO ) THEN WI = WI*WSCALE WR2 = WR1 SCALE2 = SCALE1 END IF ELSE SCALE1 = ASCALE*BSIZE SCALE2 = SCALE1 END IF * * Scale second eigenvalue (if real) * IF( WI.EQ.ZERO ) THEN WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ), $ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) ) IF( WSIZE.NE.ONE ) THEN WSCALE = ONE / WSIZE IF( WSIZE.GT.ONE ) THEN SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )* $ MIN( ASCALE, BSIZE ) ELSE SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )* $ MAX( ASCALE, BSIZE ) END IF WR2 = WR2*WSCALE ELSE SCALE2 = ASCALE*BSIZE END IF END IF * * End of DLAG2 * RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlag2s.f000066400000000000000000000100131522610125300261210ustar00rootroot00000000000000*> \brief \b DLAG2S converts a double precision matrix to a single precision matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAG2S + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDSA, M, N * .. * .. Array Arguments .. * REAL SA( LDSA, * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE *> PRECISION matrix, A. *> *> 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 conversion is aborted and a flag is raised. *> *> This is an auxiliary routine so there is no argument checking. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of lines 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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N coefficient matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] SA *> \verbatim *> SA is REAL array, dimension (LDSA,N) *> On exit, if INFO=0, the M-by-N coefficient matrix SA; if *> INFO>0, the content of SA is unspecified. *> \endverbatim *> *> \param[in] LDSA *> \verbatim *> LDSA is INTEGER *> The leading dimension of the array SA. LDSA >= max(1,M). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> = 1: an entry of the matrix A is greater than the SINGLE *> PRECISION overflow threshold, in this case, the content *> of SA in exit is unspecified. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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, LDSA, M, N * .. * .. Array Arguments .. REAL SA( LDSA, * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION RMAX * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Executable Statements .. * RMAX = SLAMCH( 'O' ) DO 20 J = 1, N DO 10 I = 1, M IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) THEN INFO = 1 GO TO 30 END IF SA( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE INFO = 0 30 CONTINUE RETURN * * End of DLAG2S * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlagv2.f000066400000000000000000000250241522610125300261340ustar00rootroot00000000000000*> \brief \b DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAGV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), * $ B( LDB, * ), BETA( 2 ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 *> matrix pencil (A,B) where B is upper triangular. This routine *> computes orthogonal (rotation) matrices given by CSL, SNL and CSR, *> SNR such that *> *> 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 *> types), then *> *> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] *> [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] *> *> [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] *> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], *> *> 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, *> then *> *> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] *> [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] *> *> [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] *> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] *> *> where b11 >= b22 > 0. *> *> \endverbatim * * Arguments: * ========== * *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, 2) *> On entry, the 2 x 2 matrix A. *> On exit, A is overwritten by the ``A-part'' of the *> generalized Schur form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> THe leading dimension of the array A. LDA >= 2. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, 2) *> On entry, the upper triangular 2 x 2 matrix B. *> On exit, B is overwritten by the ``B-part'' of the *> generalized Schur form. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> THe leading dimension of the array B. LDB >= 2. *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (2) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (2) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (2) *> (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the *> pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may *> be zero. *> \endverbatim *> *> \param[out] CSL *> \verbatim *> CSL is DOUBLE PRECISION *> The cosine of the left rotation matrix. *> \endverbatim *> *> \param[out] SNL *> \verbatim *> SNL is DOUBLE PRECISION *> The sine of the left rotation matrix. *> \endverbatim *> *> \param[out] CSR *> \verbatim *> CSR is DOUBLE PRECISION *> The cosine of the right rotation matrix. *> \endverbatim *> *> \param[out] SNR *> \verbatim *> SNR is DOUBLE PRECISION *> The sine of the right rotation matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, LDB DOUBLE PRECISION CSL, CSR, SNL, SNR * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), $ B( LDB, * ), BETA( 2 ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ, $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1, $ WR2 * .. * .. External Subroutines .. EXTERNAL DLAG2, DLARTG, DLASV2, DROT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'P' ) * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A( 1, 1 ) = ASCALE*A( 1, 1 ) A( 1, 2 ) = ASCALE*A( 1, 2 ) A( 2, 1 ) = ASCALE*A( 2, 1 ) A( 2, 2 ) = ASCALE*A( 2, 2 ) * * Scale B * BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ), $ SAFMIN ) BSCALE = ONE / BNORM B( 1, 1 ) = BSCALE*B( 1, 1 ) B( 1, 2 ) = BSCALE*B( 1, 2 ) B( 2, 2 ) = BSCALE*B( 2, 2 ) * * Check if A can be deflated * IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN CSL = ONE SNL = ZERO CSR = ONE SNR = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * * Check if B is singular * ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) CSR = ONE SNR = ZERO CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) A( 2, 1 ) = ZERO B( 1, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T ) SNR = -SNR CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) CSL = ONE SNL = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO B( 2, 2 ) = ZERO WI = ZERO * ELSE * * B is nonsingular, first compute the eigenvalues of (A,B) * CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, $ WI ) * IF( WI.EQ.ZERO ) THEN * * two real eigenvalues, compute s*A-w*B * H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 ) H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 ) H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 ) * RR = DLAPY2( H1, H2 ) QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 ) * IF( RR.GT.QQ ) THEN * * find right rotation matrix to zero 1,1 element of * (sA - wB) * CALL DLARTG( H2, H1, CSR, SNR, T ) * ELSE * * find right rotation matrix to zero 2,1 element of * (sA - wB) * CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T ) * END IF * SNR = -SNR CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) * * compute inf norms of A and B * H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ), $ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) ) H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) * IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN * * find left rotation matrix Q to zero out B(2,1) * CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R ) * ELSE * * find left rotation matrix Q to zero out A(2,1) * CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) * END IF * CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) * A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO * ELSE * * a pair of complex conjugate eigenvalues * first compute the SVD of the matrix B * CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR, $ CSR, SNL, CSL ) * * Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and * Z is right rotation matrix computed from DLASV2 * CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) * B( 2, 1 ) = ZERO B( 1, 2 ) = ZERO * END IF * END IF * * Unscaling * A( 1, 1 ) = ANORM*A( 1, 1 ) A( 2, 1 ) = ANORM*A( 2, 1 ) A( 1, 2 ) = ANORM*A( 1, 2 ) A( 2, 2 ) = ANORM*A( 2, 2 ) B( 1, 1 ) = BNORM*B( 1, 1 ) B( 2, 1 ) = BNORM*B( 2, 1 ) B( 1, 2 ) = BNORM*B( 1, 2 ) B( 2, 2 ) = BNORM*B( 2, 2 ) * IF( WI.EQ.ZERO ) THEN ALPHAR( 1 ) = A( 1, 1 ) ALPHAR( 2 ) = A( 2, 2 ) ALPHAI( 1 ) = ZERO ALPHAI( 2 ) = ZERO BETA( 1 ) = B( 1, 1 ) BETA( 2 ) = B( 2, 2 ) ELSE ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM ALPHAR( 2 ) = ALPHAR( 1 ) ALPHAI( 2 ) = -ALPHAI( 1 ) BETA( 1 ) = ONE BETA( 2 ) = ONE END IF * RETURN * * End of DLAGV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlahqr.f000066400000000000000000000471741522610125300262420ustar00rootroot00000000000000*> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAHQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAHQR is an auxiliary routine called by DHSEQR to update the *> eigenvalues and Schur decomposition already computed by DHSEQR, by *> dealing with the Hessenberg submatrix in rows and columns ILO to *> IHI. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper quasi-triangular in *> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless *> ILO = 1). DLAHQR works primarily with the Hessenberg *> submatrix in rows and columns ILO to IHI, but applies *> transformations to all of H if WANTT is .TRUE.. *> 1 <= ILO <= max(1,IHI); IHI <= N. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO is zero and if WANTT is .TRUE., H is upper *> quasi-triangular in rows and columns ILO:IHI, with any *> 2-by-2 diagonal blocks in standard form. If INFO is zero *> and WANTT is .FALSE., the contents of H are unspecified on *> exit. The output state of H if INFO is nonzero is given *> below under the description of INFO. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> The real and imaginary parts, respectively, of the computed *> eigenvalues ILO to IHI are stored in the corresponding *> elements of WR and WI. If two eigenvalues are computed as a *> complex conjugate pair, they are stored in consecutive *> elements of WR and WI, say the i-th and (i+1)th, with *> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the *> eigenvalues are stored in the same order as on the diagonal *> of the Schur form returned in H, with WR(i) = H(i,i), and, if *> H(i:i+1,i:i+1) is a 2-by-2 diagonal block, *> WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> If WANTZ is .TRUE., on entry Z must contain the current *> matrix Z of transformations accumulated by DHSEQR, and on *> exit Z has been updated; transformations are applied only to *> the submatrix Z(ILOZ:IHIZ,ILO:IHI). *> If WANTZ is .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: If INFO = i, DLAHQR failed to compute all the *> eigenvalues ILO to IHI in a total of 30 iterations *> per eigenvalue; elements i+1:ihi of WR and WI *> contain those eigenvalues which have been *> successfully computed. *> *> If INFO .GT. 0 and WANTT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the *> eigenvalues of the upper Hessenberg matrix rows *> and columns ILO thorugh INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> (*) (initial value of H)*U = U*(final value of H) *> where U is an orthognal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> (final value of Z) = (initial value of Z)*U *> where U is the orthogonal matrix in (*) *> (regardless of the value of WANTT.) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> 02-96 Based on modifications by *> David Day, Sandia National Laboratory, USA *> *> 12-04 Further modifications by *> Ralph Byers, University of Kansas, USA *> This is a modified version of DLAHQR from LAPACK version 3.0. *> It is (1) more robust against overflow and underflow and *> (2) adopts the more conservative Ahues & Tisseur stopping *> criterion (LAWN 122, 1997). *> \endverbatim *> * ===================================================================== SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * ========================================================= * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) DOUBLE PRECISION DAT1, DAT2 PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, $ ULP, V2, V3 INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * ==== clear out the trash ==== DO 10 J = ILO, IHI - 3 H( J+2, J ) = ZERO H( J+3, J ) = ZERO 10 CONTINUE IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITMAX is the total number of QR iterations allowed. * 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 * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 20 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 160 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * DO 140 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * DO 30 K = I, L + 1, -1 IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) $ GO TO 40 TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST.EQ.ZERO ) THEN IF( K-2.GE.ILO ) $ TST = TST + ABS( H( K-1, K-2 ) ) IF( K+1.LE.IHI ) $ TST = TST + ABS( H( K+1, K ) ) END IF * ==== The following is a conservative small subdiagonal * . deflation criterion due to Ahues & Tisseur (LAWN 122, * . 1997). It has better mathematical foundation and * . improves accuracy in some cases. ==== IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) AA = MAX( ABS( H( K, K ) ), $ ABS( H( K-1, K-1 )-H( K, K ) ) ) BB = MIN( ABS( H( K, K ) ), $ ABS( H( K-1, K-1 )-H( K, K ) ) ) S = AA + AB IF( BA*( AB / S ).LE.MAX( SMLNUM, $ ULP*( BB*( AA / S ) ) ) )GO TO 40 END IF 30 CONTINUE 40 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) $ GO TO 150 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 ) THEN * * Exceptional shift. * S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) H11 = DAT1*S + H( L, L ) H12 = DAT2*S H21 = S H22 = H11 ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H11 = DAT1*S + H( I, I ) H12 = DAT2*S H21 = S H22 = H11 ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * H11 = H( I-1, I-1 ) H21 = H( I, I-1 ) H12 = H( I-1, I ) H22 = H( I, I ) END IF S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) IF( S.EQ.ZERO ) THEN RT1R = ZERO RT1I = ZERO RT2R = ZERO RT2I = ZERO ELSE H11 = H11 / S H21 = H21 / S H12 = H12 / S H22 = H22 / S TR = ( H11+H22 ) / TWO DET = ( H11-TR )*( H22-TR ) - H12*H21 RTDISC = SQRT( ABS( DET ) ) IF( DET.GE.ZERO ) THEN * * ==== complex conjugate shifts ==== * RT1R = TR*S RT2R = RT1R RT1I = RTDISC*S RT2I = -RT1I ELSE * * ==== real shifts (use only one of them) ==== * RT1R = TR + RTDISC RT2R = TR - RTDISC IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN RT1R = RT1R*S RT2R = RT1R ELSE RT2R = RT2R*S RT1R = RT2R END IF RT1I = ZERO RT2I = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 50 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. (The following uses scaling to avoid * overflows and most underflows.) * H21S = H( M+1, M ) S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) H21S = H( M+1, M ) / S V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) V( 3 ) = H21S*H( M+2, M+1 ) S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) V( 1 ) = V( 1 ) / S V( 2 ) = V( 2 ) / S V( 3 ) = V( 3 ) / S IF( M.EQ.L ) $ GO TO 60 IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 50 CONTINUE 60 CONTINUE * * Double-shift QR step * DO 130 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( 3, I-K+1 ) IF( K.GT.M ) $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN * ==== Use the following instead of * . H( K, K-1 ) = -H( K, K-1 ) to * . avoid a bug when v(2) and v(3) * . underflow. ==== H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) END IF V2 = V( 2 ) T2 = T1*V2 IF( NR.EQ.3 ) THEN V3 = V( 3 ) T3 = T1*V3 * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 70 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 70 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 80 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 80 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 90 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 90 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 100 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 100 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 110 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 110 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 120 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 120 CONTINUE END IF END IF 130 CONTINUE * 140 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 150 CONTINUE * IF( L.EQ.I ) THEN * * H(I,I-1) is negligible: one eigenvalue has converged. * WR( I ) = H( I, I ) WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN * * H(I-1,I-2) is negligible: a pair of eigenvalues have converged. * * Transform the 2-by-2 submatrix to standard Schur form, * and compute and store the eigenvalues. * CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), $ CS, SN ) * IF( WANTT ) THEN * * Apply the transformation to the rest of H. * IF( I2.GT.I ) $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, $ CS, SN ) CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) END IF IF( WANTZ ) THEN * * Apply the transformation to Z. * CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) END IF END IF * * return to start of the main loop with new value of I. * I = L - 1 GO TO 20 * 160 CONTINUE RETURN * * End of DLAHQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlahr2.f000066400000000000000000000237201522610125300261320ustar00rootroot00000000000000*> \brief \b DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAHR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) *> matrix A so that elements below the k-th subdiagonal are zero. The *> reduction is performed by an orthogonal similarity transformation *> Q**T * A * Q. The routine returns the matrices V and T which determine *> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. *> *> This is an auxiliary routine called by DGEHRD. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The offset for the reduction. Elements below the k-th *> subdiagonal in the first NB columns are reduced to zero. *> K < N. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N-K+1) *> On entry, the n-by-(n-k+1) general matrix A. *> On exit, the elements on and above the k-th subdiagonal in *> the first NB columns are overwritten with the corresponding *> elements of the reduced matrix; the elements below the k-th *> subdiagonal, with the array TAU, represent the matrix Q as a *> product of elementary reflectors. The other columns of A are *> unchanged. 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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors. See Further *> Details. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NB) *> The upper triangular matrix T. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (LDY,NB) *> The n-by-nb matrix Y. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of nb elementary reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in *> A(i+k+1:n,i), and tau in TAU(i). *> *> The elements of the vectors v together form the (n-k+1)-by-nb matrix *> V which is needed, with T and Y, to apply the transformation to the *> unreduced part of the matrix, using an update of the form: *> A := (I - V*T*V**T) * (A - Y*V**T). *> *> The contents of A on exit are illustrated by the following example *> with n = 7, k = 3 and nb = 2: *> *> ( a a a a a ) *> ( a a a a a ) *> ( a a a a a ) *> ( h h a a a ) *> ( v1 h a a a ) *> ( v1 v2 a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This subroutine is a slight modification of LAPACK-3.0's DLAHRD *> incorporating improvements proposed by Quintana-Orti and Van de *> Gejin. Note that the entries of A(1:K,2:NB) differ from those *> returned by the original LAPACK-3.0's DLAHRD routine. (This *> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) *> \endverbatim * *> \par References: * ================ *> *> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the *> performance of reduction to Hessenberg form," ACM Transactions on *> Mathematical Software, 32(2):180-194, June 2006. *> * ===================================================================== SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.7.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 K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, $ DLARFG, DSCAL, DTRMM, DTRMV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(K+1:N,I) * * Update I-th column of A - Y * V**T * CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) * * Apply I - V * T**T * V**T to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1**T * b1 * CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) 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, $ 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', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * 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', $ '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 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(I) to annihilate * A(K+I+1:N,I) * CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(K+1:N,I) * 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, $ 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, $ 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 ) * * Compute T(1:I,I) * CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * * Compute Y(1:K,1:NB) * CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) 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, $ 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', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * RETURN * * End of DLAHR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaic1.f000066400000000000000000000236141522610125300261150ustar00rootroot00000000000000*> \brief \b DLAIC1 applies one step of incremental condition estimation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAIC1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION W( J ), X( J ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAIC1 applies one step of incremental condition estimation in *> its simplest version: *> *> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j *> lower triangular matrix L, such that *> twonorm(L*x) = sest *> Then DLAIC1 computes sestpr, s, c such that *> the vector *> [ s*x ] *> xhat = [ c ] *> is an approximate singular vector of *> [ L 0 ] *> Lhat = [ w**T gamma ] *> in the sense that *> twonorm(Lhat*xhat) = sestpr. *> *> Depending on JOB, an estimate for the largest or smallest singular *> value is computed. *> *> Note that [s c]**T and sestpr**2 is an eigenpair of the system *> *> diag(sest*sest, 0) + [alpha gamma] * [ alpha ] *> [ gamma ] *> *> where alpha = x**T*w. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is INTEGER *> = 1: an estimate for the largest singular value is computed. *> = 2: an estimate for the smallest singular value is computed. *> \endverbatim *> *> \param[in] J *> \verbatim *> J is INTEGER *> Length of X and W *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (J) *> The j-vector x. *> \endverbatim *> *> \param[in] SEST *> \verbatim *> SEST is DOUBLE PRECISION *> Estimated singular value of j by j matrix L *> \endverbatim *> *> \param[in] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (J) *> The j-vector w. *> \endverbatim *> *> \param[in] GAMMA *> \verbatim *> GAMMA is DOUBLE PRECISION *> The diagonal element gamma. *> \endverbatim *> *> \param[out] SESTPR *> \verbatim *> SESTPR is DOUBLE PRECISION *> Estimated singular value of (j+1) by (j+1) matrix Lhat. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION *> Sine needed in forming xhat. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION *> Cosine needed in forming xhat. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * -- LAPACK auxiliary routine (version 3.7.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 J, JOB DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR * .. * .. Array Arguments .. DOUBLE PRECISION W( J ), X( J ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) DOUBLE PRECISION HALF, FOUR PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS, $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH EXTERNAL DDOT, DLAMCH * .. * .. Executable Statements .. * EPS = DLAMCH( 'Epsilon' ) ALPHA = DDOT( J, X, 1, W, 1 ) * ABSALP = ABS( ALPHA ) ABSGAM = ABS( GAMMA ) ABSEST = ABS( SEST ) * IF( JOB.EQ.1 ) THEN * * Estimating largest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN S1 = MAX( ABSGAM, ABSALP ) IF( S1.EQ.ZERO ) THEN S = ZERO C = ONE SESTPR = ZERO ELSE S = ALPHA / S1 C = GAMMA / S1 TMP = SQRT( S*S+C*C ) S = S / TMP C = C / TMP SESTPR = S1*TMP END IF RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ONE C = ZERO TMP = MAX( ABSEST, ABSALP ) S1 = ABSEST / TMP S2 = ABSALP / TMP SESTPR = TMP*SQRT( S1*S1+S2*S2 ) RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ONE C = ZERO SESTPR = S2 ELSE S = ZERO C = ONE SESTPR = S1 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 S = SQRT( ONE+TMP*TMP ) SESTPR = S2*S C = ( GAMMA / S2 ) / S S = SIGN( ONE, ALPHA ) / S ELSE TMP = S2 / S1 C = SQRT( ONE+TMP*TMP ) SESTPR = S1*C S = ( ALPHA / S1 ) / C C = SIGN( ONE, GAMMA ) / C END IF RETURN ELSE * * normal case * ZETA1 = ALPHA / ABSEST ZETA2 = GAMMA / ABSEST * B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF C = ZETA1*ZETA1 IF( B.GT.ZERO ) THEN T = C / ( B+SQRT( B*B+C ) ) ELSE T = SQRT( B*B+C ) - B END IF * SINE = -ZETA1 / T COSINE = -ZETA2 / ( ONE+T ) TMP = SQRT( SINE*SINE+COSINE*COSINE ) S = SINE / TMP C = COSINE / TMP SESTPR = SQRT( T+ONE )*ABSEST RETURN END IF * ELSE IF( JOB.EQ.2 ) THEN * * Estimating smallest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN SESTPR = ZERO IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN SINE = ONE COSINE = ZERO ELSE SINE = -GAMMA COSINE = ALPHA END IF S1 = MAX( ABS( SINE ), ABS( COSINE ) ) S = SINE / S1 C = COSINE / S1 TMP = SQRT( S*S+C*C ) S = S / TMP C = C / TMP RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ZERO C = ONE SESTPR = ABSGAM RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ZERO C = ONE SESTPR = S1 ELSE S = ONE C = ZERO SESTPR = S2 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 C = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST*( TMP / C ) S = -( GAMMA / S2 ) / C C = SIGN( ONE, ALPHA ) / C ELSE TMP = S2 / S1 S = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST / S C = ( ALPHA / S1 ) / S S = -SIGN( ONE, GAMMA ) / S END IF RETURN ELSE * * normal case * ZETA1 = ALPHA / ABSEST ZETA2 = GAMMA / ABSEST * NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ), $ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 ) * * See if root is closer to zero or to ONE * TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) IF( TEST.GE.ZERO ) THEN * * root is close to zero, compute directly * B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF C = ZETA2*ZETA2 T = C / ( B+SQRT( ABS( B*B-C ) ) ) SINE = ZETA1 / ( ONE-T ) COSINE = -ZETA2 / T SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST ELSE * * root is closer to ONE, shift by that amount * B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF C = ZETA1*ZETA1 IF( B.GE.ZERO ) THEN T = -C / ( B+SQRT( B*B+C ) ) ELSE T = B - SQRT( B*B+C ) END IF SINE = -ZETA1 / T COSINE = -ZETA2 / ( ONE+T ) SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST END IF TMP = SQRT( SINE*SINE+COSINE*COSINE ) S = SINE / TMP C = COSINE / TMP RETURN * END IF END IF RETURN * * End of DLAIC1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaisnan.f000066400000000000000000000050361522610125300265470ustar00rootroot00000000000000*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAISNAN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) * * .. Scalar Arguments .. * DOUBLE PRECISION DIN1, DIN2 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is not for general use. It exists solely to avoid *> over-optimization in DISNAN. *> *> DLAISNAN checks for NaNs by comparing its two arguments for *> inequality. NaN is the only floating-point value where NaN != NaN *> returns .TRUE. To check for NaNs, pass the same variable as both *> arguments. *> *> A compiler must assume that the two arguments are *> not the same variable, and the test will not be optimized away. *> Interprocedural or whole-program optimization may delete this *> test. The ISNAN functions will be replaced by the correct *> Fortran 03 intrinsic once the intrinsic is widely available. *> \endverbatim * * Arguments: * ========== * *> \param[in] DIN1 *> \verbatim *> DIN1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] DIN2 *> \verbatim *> DIN2 is DOUBLE PRECISION *> Two numbers to compare for inequality. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION DIN1, DIN2 * .. * * ===================================================================== * * .. Executable Statements .. DLAISNAN = (DIN1.NE.DIN2) RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaln2.f000066400000000000000000000451651522610125300261410ustar00rootroot00000000000000*> \brief \b DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLALN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLALN2 solves a system of the form (ca A - w D ) X = s B *> or (ca A**T - w D) X = s B with possible scaling ("s") and *> perturbation of A. (A**T means A-transpose.) *> *> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA *> real diagonal matrix, w is a real or complex value, and X and B are *> NA x 1 matrices -- real if w is real, complex if w is complex. NA *> may be 1 or 2. *> *> If w is complex, X and B are represented as NA x 2 matrices, *> the first column of each being the real part and the second *> being the imaginary part. *> *> "s" is a scaling factor (.LE. 1), computed by DLALN2, which is *> so chosen that X can be computed without overflow. X is further *> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less *> than overflow. *> *> If both singular values of (ca A - w D) are less than SMIN, *> SMIN*identity will be used instead of (ca A - w D). If only one *> singular value is less than SMIN, one element of (ca A - w D) will be *> perturbed enough to make the smallest singular value roughly SMIN. *> If both singular values are at least SMIN, (ca A - w D) will not be *> perturbed. In any case, the perturbation will be at most some small *> multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values *> are computed by infinity-norm approximations, and thus will only be *> correct to a factor of 2 or so. *> *> Note: all input quantities are assumed to be smaller than overflow *> by a reasonable factor. (See BIGNUM.) *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRANS *> \verbatim *> LTRANS is LOGICAL *> =.TRUE.: A-transpose will be used. *> =.FALSE.: A will be used (not transposed.) *> \endverbatim *> *> \param[in] NA *> \verbatim *> NA is INTEGER *> The size of the matrix A. It may (only) be 1 or 2. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> 1 if "w" is real, 2 if "w" is complex. It may only be 1 *> or 2. *> \endverbatim *> *> \param[in] SMIN *> \verbatim *> SMIN is DOUBLE PRECISION *> The desired lower bound on the singular values of A. This *> should be a safe distance away from underflow or overflow, *> say, between (underflow/machine precision) and (machine *> precision * overflow ). (See BIGNUM and ULP.) *> \endverbatim *> *> \param[in] CA *> \verbatim *> CA is DOUBLE PRECISION *> The coefficient c, which A is multiplied by. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,NA) *> The NA x NA matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. It must be at least NA. *> \endverbatim *> *> \param[in] D1 *> \verbatim *> D1 is DOUBLE PRECISION *> The 1,1 element in the diagonal matrix D. *> \endverbatim *> *> \param[in] D2 *> \verbatim *> D2 is DOUBLE PRECISION *> The 2,2 element in the diagonal matrix D. Not used if NA=1. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NW) *> The NA x NW matrix B (right-hand side). If NW=2 ("w" is *> complex), column 1 contains the real part of B and column 2 *> contains the imaginary part. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. It must be at least NA. *> \endverbatim *> *> \param[in] WR *> \verbatim *> WR is DOUBLE PRECISION *> The real part of the scalar "w". *> \endverbatim *> *> \param[in] WI *> \verbatim *> WI is DOUBLE PRECISION *> The imaginary part of the scalar "w". Not used if NW=1. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NW) *> The NA x NW matrix X (unknowns), as computed by DLALN2. *> If NW=2 ("w" is complex), on exit, column 1 will contain *> the real part of X and column 2 will contain the imaginary *> part. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of X. It must be at least NA. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scale factor that B must be multiplied by to insure *> that overflow does not occur when computing X. Thus, *> (ca A - w D) X will be SCALE*B, not B (ignoring *> perturbations of A.) It will be at most 1. *> \endverbatim *> *> \param[out] XNORM *> \verbatim *> XNORM is DOUBLE PRECISION *> The infinity-norm of X, when X is regarded as an NA x NW *> real matrix. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> An error flag. It will be set to zero if no error occurs, *> a negative number if an argument is in error, or a positive *> number if ca A - w D had to be perturbed. *> The possible values are: *> = 0: No error occurred, and (ca A - w D) did not have to be *> perturbed. *> = 1: (ca A - w D) had to be perturbed to make its smallest *> (or only) singular value greater than SMIN. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== 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.7.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 LTRANS INTEGER INFO, LDA, LDB, LDX, NA, NW DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. INTEGER ICMAX, J DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, $ UR22, XI1, XI2, XR1, XR2 * .. * .. Local Arrays .. LOGICAL RSWAP( 4 ), ZSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Equivalences .. EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), $ ( CR( 1, 1 ), CRV( 1 ) ) * .. * .. Data statements .. DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / * .. * .. Executable Statements .. * * Compute BIGNUM * SMLNUM = TWO*DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) * * Don't check for input errors * INFO = 0 * * Standard Initializations * SCALE = ONE * IF( NA.EQ.1 ) THEN * * 1 x 1 (i.e., scalar) system C X = B * IF( NW.EQ.1 ) THEN * * Real 1x1 system. * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CNORM = ABS( CSR ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR XNORM = ABS( X( 1, 1 ) ) ELSE * * Complex 1x1 system (w is complex) * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CSI = -WI*D1 CNORM = ABS( CSR ) + ABS( CSI ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CSI = ZERO CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, $ X( 1, 1 ), X( 1, 2 ) ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) END IF * ELSE * * 2x2 System * * Compute the real part of C = ca A - w D (or ca A**T - w D ) * CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 IF( LTRANS ) THEN CR( 1, 2 ) = CA*A( 2, 1 ) CR( 2, 1 ) = CA*A( 1, 2 ) ELSE CR( 2, 1 ) = CA*A( 2, 1 ) CR( 1, 2 ) = CA*A( 1, 2 ) END IF * IF( NW.EQ.1 ) THEN * * Real 2x2 system (w is real) * * Find the largest element in C * CMAX = ZERO ICMAX = 0 * DO 10 J = 1, 4 IF( ABS( CRV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) ICMAX = J END IF 10 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) UR11R = ONE / UR11 LR21 = UR11R*CR21 UR22 = CR22 - UR12*LR21 * * If smaller pivot < SMINI, use SMINI * IF( ABS( UR22 ).LT.SMINI ) THEN UR22 = SMINI INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR1 = B( 2, 1 ) BR2 = B( 1, 1 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) END IF BR2 = BR2 - LR21*BR1 BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( UR22 ) ) $ SCALE = ONE / BBND END IF * XR2 = ( BR2*SCALE ) / UR22 XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 END IF XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF ELSE * * Complex 2x2 system (w is complex) * * Find the largest element in C * CI( 1, 1 ) = -WI*D1 CI( 2, 1 ) = ZERO CI( 1, 2 ) = ZERO CI( 2, 2 ) = -WI*D2 CMAX = ZERO ICMAX = 0 * DO 20 J = 1, 4 IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) ICMAX = J END IF 20 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) X( 1, 2 ) = TEMP*B( 1, 2 ) X( 2, 2 ) = TEMP*B( 2, 2 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) UI11 = CIV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) CI21 = CIV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) UI12 = CIV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) CI22 = CIV( IPIVOT( 4, ICMAX ) ) IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN * * Code when off-diagonals of pivoted C are real * IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN TEMP = UI11 / UR11 UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) UI11R = -TEMP*UR11R ELSE TEMP = UR11 / UI11 UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) UR11R = -TEMP*UI11R END IF LR21 = CR21*UR11R LI21 = CR21*UI11R UR12S = UR12*UR11R UI12S = UR12*UI11R UR22 = CR22 - UR12*LR21 UI22 = CI22 - UR12*LI21 ELSE * * Code when diagonals of pivoted C are real * UR11R = ONE / UR11 UI11R = ZERO LR21 = CR21*UR11R LI21 = CI21*UR11R UR12S = UR12*UR11R UI12S = UI12*UR11R UR22 = CR22 - UR12*LR21 + UI12*LI21 UI22 = -UR12*LI21 - UI12*LR21 END IF U22ABS = ABS( UR22 ) + ABS( UI22 ) * * If smaller pivot < SMINI, use SMINI * IF( U22ABS.LT.SMINI ) THEN UR22 = SMINI UI22 = ZERO INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR2 = B( 1, 1 ) BR1 = B( 2, 1 ) BI2 = B( 1, 2 ) BI1 = B( 2, 2 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) BI1 = B( 1, 2 ) BI2 = B( 2, 2 ) END IF BR2 = BR2 - LR21*BR1 + LI21*BI1 BI2 = BI2 - LI21*BR1 - LR21*BI1 BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), $ ABS( BR2 )+ABS( BI2 ) ) IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN IF( BBND.GE.BIGNUM*U22ABS ) THEN SCALE = ONE / BBND BR1 = SCALE*BR1 BI1 = SCALE*BI1 BR2 = SCALE*BR2 BI2 = SCALE*BI2 END IF END IF * CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 X( 1, 2 ) = XI2 X( 2, 2 ) = XI1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 X( 1, 2 ) = XI1 X( 2, 2 ) = XI2 END IF XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) X( 1, 2 ) = TEMP*X( 1, 2 ) X( 2, 2 ) = TEMP*X( 2, 2 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF END IF END IF * RETURN * * End of DLALN2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlamch.f000066400000000000000000000122031522610125300262000ustar00rootroot00000000000000*> \brief \b DLAMCH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAMCH determines double precision machine parameters. *> \endverbatim * * Arguments: * ========== * *> \param[in] CMACH *> \verbatim *> Specifies the value to be returned by DLAMCH: *> = 'E' or 'e', DLAMCH := eps *> = 'S' or 's , DLAMCH := sfmin *> = 'B' or 'b', DLAMCH := base *> = 'P' or 'p', DLAMCH := eps*base *> = 'N' or 'n', DLAMCH := t *> = 'R' or 'r', DLAMCH := rnd *> = 'M' or 'm', DLAMCH := emin *> = 'U' or 'u', DLAMCH := rmin *> = 'L' or 'l', DLAMCH := emax *> = 'O' or 'o', DLAMCH := rmax *> where *> eps = relative machine precision *> sfmin = safe minimum, such that 1/sfmin does not overflow *> base = base of the machine *> prec = eps*base *> t = number of (base) digits in the mantissa *> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise *> emin = minimum exponent before (gradual) underflow *> rmin = underflow threshold - base**(emin-1) *> emax = largest exponent before overflow *> rmax = overflow threshold - (base**emax)*(1-eps) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 3.7.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 CMACH * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, $ MINEXPONENT, RADIX, TINY * .. * .. Executable Statements .. * * * Assume rounding, not chopping. Always. * RND = ONE * IF( ONE.EQ.RND ) THEN EPS = EPSILON(ZERO) * 0.5 ELSE EPS = EPSILON(ZERO) END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN SFMIN = TINY(ZERO) SMALL = ONE / HUGE(ZERO) IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = RADIX(ZERO) ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = EPS * RADIX(ZERO) ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = DIGITS(ZERO) ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = MINEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = tiny(zero) ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = MAXEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = HUGE(ZERO) ELSE RMACH = ZERO END IF * DLAMCH = RMACH RETURN * * End of DLAMCH * END ************************************************************************ *> \brief \b DLAMC3 *> \details *> \b Purpose: *> \verbatim *> DLAMC3 is intended to force A and B to be stored prior to doing *> the addition of A and B , for use in situations where optimizers *> 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 December 2016 *> \ingroup auxOTHERauxiliary *> *> \param[in] A *> \verbatim *> A is a DOUBLE PRECISION *> \endverbatim *> *> \param[in] B *> \verbatim *> B is a DOUBLE PRECISION *> The values A and B. *> \endverbatim *> DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * * .. Scalar Arguments .. DOUBLE PRECISION A, B * .. * ===================================================================== * * .. Executable Statements .. * DLAMC3 = A + B * RETURN * * End of DLAMC3 * END * ************************************************************************ qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlamtsqr.f000066400000000000000000000270631522610125300266110ustar00rootroot00000000000000*> \brief \b DLAMTSQR * * 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] 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlanhs.f000066400000000000000000000132231522610125300262240ustar00rootroot00000000000000*> \brief \b DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANHS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANHS returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> Hessenberg matrix A. *> \endverbatim *> *> \return DLANHS *> \verbatim *> *> DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANHS as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANHS is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The n by n upper Hessenberg matrix A; the part of A below the *> first sub-diagonal is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANHS = VALUE RETURN * * End of DLANHS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlanst.f000066400000000000000000000123241522610125300262410ustar00rootroot00000000000000*> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANST + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANST returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real symmetric tridiagonal matrix A. *> \endverbatim *> *> \return DLANST *> \verbatim *> *> DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANST as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANST is *> set to zero. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) sub-diagonal or super-diagonal elements of A. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * * -- LAPACK auxiliary routine (version 3.7.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 NORM INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ANORM, SCALE, SUM * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 SUM = ABS( D( I ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM SUM = ABS( E( I ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. $ LSAME( NORM, 'I' ) ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) SUM = ABS( E( N-1 ) )+ABS( D( N ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM DO 20 I = 2, N - 1 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL DLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL DLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF * DLANST = ANORM RETURN * * End of DLANST * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlanv2.f000066400000000000000000000170111522610125300261400ustar00rootroot00000000000000*> \brief \b DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric *> matrix in standard form: *> *> [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] *> [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] *> *> where either *> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or *> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex *> conjugate eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION *> On entry, the elements of the input matrix. *> On exit, they are overwritten by the elements of the *> standardised Schur form. *> \endverbatim *> *> \param[out] RT1R *> \verbatim *> RT1R is DOUBLE PRECISION *> \endverbatim *> *> \param[out] RT1I *> \verbatim *> RT1I is DOUBLE PRECISION *> \endverbatim *> *> \param[out] RT2R *> \verbatim *> RT2R is DOUBLE PRECISION *> \endverbatim *> *> \param[out] RT2I *> \verbatim *> RT2I is DOUBLE PRECISION *> The real and imaginary parts of the eigenvalues. If the *> eigenvalues are a complex conjugate pair, RT1I > 0. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is DOUBLE PRECISION *> Parameters of the rotation matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by V. Sima, Research Institute for Informatics, Bucharest, *> Romania, to reduce the risk of cancellation errors, *> when computing real eigenvalues, and to ensure, if possible, that *> abs(RT1R) >= abs(RT2R). *> \endverbatim *> * ===================================================================== SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION MULTPL PARAMETER ( MULTPL = 4.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * EPS = DLAMCH( 'P' ) IF( C.EQ.ZERO ) THEN CS = ONE SN = ZERO GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN * * Swap rows and columns * CS = ZERO SN = ONE TEMP = D D = A A = TEMP B = -C C = ZERO GO TO 10 ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) $ THEN CS = ONE SN = ZERO GO TO 10 ELSE * TEMP = A - D P = HALF*TEMP BCMAX = MAX( ABS( B ), ABS( C ) ) BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) SCALE = MAX( ABS( P ), BCMAX ) Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS * * If Z is of the order of the machine accuracy, postpone the * decision on the nature of eigenvalues * IF( Z.GE.MULTPL*EPS ) THEN * * Real eigenvalues. Compute A and D. * Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) A = D + Z D = D - ( BCMAX / Z )*BCMIS * * Compute B and the rotation matrix * TAU = DLAPY2( C, Z ) CS = Z / TAU SN = C / TAU B = B - C C = ZERO ELSE * * Complex eigenvalues, or real (almost) equal eigenvalues. * Make diagonal elements equal. * SIGMA = B + C TAU = DLAPY2( SIGMA, TEMP ) CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) * * Compute [ AA BB ] = [ A B ] [ CS -SN ] * [ CC DD ] [ C D ] [ SN CS ] * AA = A*CS + B*SN BB = -A*SN + B*CS CC = C*CS + D*SN DD = -C*SN + D*CS * * Compute [ A B ] = [ CS SN ] [ AA BB ] * [ C D ] [-SN CS ] [ CC DD ] * A = AA*CS + CC*SN B = BB*CS + DD*SN C = -AA*SN + CC*CS D = -BB*SN + DD*CS * TEMP = HALF*( A+D ) A = TEMP D = TEMP * IF( C.NE.ZERO ) THEN IF( B.NE.ZERO ) THEN IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * * Real eigenvalues: reduce to upper triangular form * SAB = SQRT( ABS( B ) ) SAC = SQRT( ABS( C ) ) P = SIGN( SAB*SAC, C ) TAU = ONE / SQRT( ABS( B+C ) ) A = TEMP + P D = TEMP - P B = B - C C = ZERO CS1 = SAB*TAU SN1 = SAC*TAU TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP END IF ELSE B = -C C = ZERO TEMP = CS CS = -SN SN = TEMP END IF END IF END IF * END IF * 10 CONTINUE * * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). * RT1R = A RT2R = D IF( C.EQ.ZERO ) THEN RT1I = ZERO RT2I = ZERO ELSE RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) RT2I = -RT1I END IF RETURN * * End of DLANV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlapy2.f000066400000000000000000000054661522610125300261600ustar00rootroot00000000000000*> \brief \b DLAPY2 returns sqrt(x2+y2). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * .. Scalar Arguments .. * DOUBLE PRECISION X, Y * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary *> overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is DOUBLE PRECISION *> X and Y specify the values x and y. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z LOGICAL X_IS_NAN, Y_IS_NAN * .. * .. External Functions .. LOGICAL DISNAN EXTERNAL DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * X_IS_NAN = DISNAN( X ) Y_IS_NAN = DISNAN( Y ) IF ( X_IS_NAN ) DLAPY2 = X IF ( Y_IS_NAN ) DLAPY2 = Y * IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF END IF RETURN * * End of DLAPY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlapy3.f000066400000000000000000000052661522610125300261570ustar00rootroot00000000000000*> \brief \b DLAPY3 returns sqrt(x2+y2+z2). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPY3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * .. Scalar Arguments .. * DOUBLE PRECISION X, Y, Z * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause *> unnecessary overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is DOUBLE PRECISION *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION *> X, Y and Z specify the values x, y and z. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION X, Y, Z * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN * W can be zero for max(0,nan,0) * adding all three entries together will make sure * NaN will not disappear. DLAPY3 = XABS + YABS + ZABS ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of DLAPY3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqp2.f000066400000000000000000000167731522610125300261530ustar00rootroot00000000000000*> \brief \b DLAQP2 computes a QR factorization with column pivoting of the matrix block. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQP2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) * * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQP2 computes a QR factorization with column pivoting of *> the block A(OFFSET+1:M,1:N). *> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted *> but no factorized. OFFSET >= 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 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is DOUBLE PRECISION array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is DOUBLE PRECISION array, dimension (N) *> The vector with the exact column norms. *> \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 doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, M, N, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * MN = MIN( M-OFFSET, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Compute factorization. * DO 20 I = 1, MN * OFFPI = OFFSET + I * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) * IF( PVT.NE.I ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP VN1( PVT ) = VN1( I ) VN2( PVT ) = VN2( I ) END IF * * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, $ TAU( I ) ) ELSE CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i)**T to A(offset+i:m,i+1:n) from the left. * AII = A( OFFPI, I ) A( OFFPI, I ) = ONE CALL DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) A( OFFPI, I ) = AII END IF * * Update partial column norms. * DO 10 J = I + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( OFFPI.LT.M ) THEN VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) VN2( J ) = VN1( J ) ELSE VN1( J ) = ZERO VN2( J ) = ZERO END IF ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 10 CONTINUE * 20 CONTINUE * RETURN * * End of DLAQP2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqps.f000066400000000000000000000245131522610125300262430ustar00rootroot00000000000000*> \brief \b DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQPS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), * $ VN1( * ), VN2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQPS computes a step of QR factorization with column pivoting *> of a real M-by-N matrix A by using Blas-3. It tries to factorize *> NB columns from A starting from the row OFFSET+1, and updates all *> of the matrix with Blas-3 xGEMM. *> *> In some cases, due to catastrophic cancellations, it cannot *> factorize NB columns. Hence, the actual number of factorized *> columns is returned in KB. *> *> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of A that have been factorized in *> previous steps. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to factorize. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER *> The number of columns actually factorized. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, block A(OFFSET+1:M,1:KB) is the triangular *> factor obtained and block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. *> The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has *> been updated. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> JPVT(I) = K <==> Column K of the full matrix A has been *> permuted into position I in AP. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (KB) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is DOUBLE PRECISION array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is DOUBLE PRECISION array, dimension (N) *> The vector with the exact column norms. *> \endverbatim *> *> \param[in,out] AUXV *> \verbatim *> AUXV is DOUBLE PRECISION array, dimension (NB) *> Auxiliar vector. *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF,NB) *> Matrix F**T = L*Y**T*A. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * * -- LAPACK auxiliary routine (version 3.7.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 KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), $ VN1( * ), VN2( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * LASTRK = MIN( M, N+OFFSET ) LSTICC = 0 K = 0 TOL3Z = SQRT(DLAMCH('Epsilon')) * * Beginning of while loop. * 10 CONTINUE IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN K = K + 1 RK = OFFSET + K * * Determine ith pivot column and swap if necessary * PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) IF( PVT.NE.K ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( K ) JPVT( K ) = ITEMP VN1( PVT ) = VN1( K ) VN2( PVT ) = VN2( K ) END IF * * Apply previous Householder reflectors to column K: * A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. * IF( K.GT.1 ) THEN CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) END IF * * Generate elementary reflector H(k). * IF( RK.LT.M ) THEN CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) ELSE CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) END IF * AKK = A( RK, K ) A( RK, K ) = ONE * * Compute Kth column of F: * * Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). * IF( K.LT.N ) THEN CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, $ F( K+1, K ), 1 ) END IF * * Padding F(1:K,K) with zeros. * DO 20 J = 1, K F( J, K ) = ZERO 20 CONTINUE * * Incremental updating of F: * F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T * *A(RK:M,K). * IF( K.GT.1 ) THEN CALL DGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) * CALL DGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF, $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) END IF * * Update the current row of A: * A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. * IF( K.LT.N ) THEN CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) END IF * * Update partial column norms. * IF( RK.LT.LASTRK ) THEN DO 30 J = K + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN VN2( J ) = DBLE( LSTICC ) LSTICC = J ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE END IF * A( RK, K ) = AKK * * End of while loop. * GO TO 10 END IF KB = K RK = OFFSET + KB * * Apply the block reflector to the rest of the matrix: * A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - * A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. * IF( KB.LT.MIN( N, M-OFFSET ) ) THEN CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, $ A( RK+1, KB+1 ), LDA ) END IF * * Recomputation of difficult columns. * 40 CONTINUE IF( LSTICC.GT.0 ) THEN 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 * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP GO TO 40 END IF * RETURN * * End of DLAQPS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqr0.f000066400000000000000000000643361522610125300261510ustar00rootroot00000000000000*> \brief \b DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR0 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**T, where T is an upper quasi-triangular matrix (the *> Schur form), and Z is the orthogonal matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input orthogonal *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to DGEBAL, and then passed to DGEHRD when the *> matrix output by DGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H contains *> the upper quasi-triangular matrix T from the Schur *> decomposition (the Schur form); 2-by-2 diagonal blocks *> (corresponding to complex conjugate pairs of eigenvalues) *> are returned in standard form, with H(i,i) = H(i+1,i+1) *> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (IHI) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (IHI) *> The real and imaginary parts, respectively, of the computed *> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) *> and WI(ILO:IHI). If two eigenvalues are computed as a *> complex conjugate pair, they are stored in consecutive *> elements of WR and WI, say the i-th and (i+1)th, with *> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then *> the eigenvalues are stored in the same order as on the *> diagonal of the Schur form returned in H, with *> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal *> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and *> WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then DLAQR0 does a workspace query. *> In this case, DLAQR0 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, DLAQR0 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is an orthogonal matrix. The final *> value of H is upper Hessenberg and quasi-triangular *> in rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== DOUBLE PRECISION WILK1, WILK2 PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. DOUBLE PRECISION ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use DLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to DLAQR3 ==== * CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, $ N, H, LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== DLAHQR/DLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 80 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 90 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, $ WORK, LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if DLAQR3 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . DLAQR3 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) AA = WILK1*SS + H( I, I ) BB = SS CC = WILK2*SS DD = AA CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) 30 CONTINUE IF( KS.EQ.KTOP ) THEN WR( KS+1 ) = H( KS+1, KS+1 ) WI( KS+1 ) = ZERO WR( KS ) = WR( KS+1 ) WI( KS ) = WI( KS+1 ) END IF ELSE * * ==== Got NS/2 or fewer shifts? Use DLAQR4 or * . DLAHQR on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) IF( NS.GT.NMIN ) THEN CALL DLAQR4( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), $ WI( KS ), 1, 1, ZDUM, 1, WORK, $ LWORK, INF ) ELSE CALL DLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), $ WI( KS ), 1, 1, ZDUM, 1, INF ) END IF KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. ==== * IF( KS.GE.KBOT ) THEN AA = H( KBOT-1, KBOT-1 ) CC = H( KBOT, KBOT-1 ) BB = H( KBOT-1, KBOT ) DD = H( KBOT, KBOT ) CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), $ WI( KBOT-1 ), WR( KBOT ), $ WI( KBOT ), CS, SN ) KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) * . Bubble sort keeps complex conjugate * . pairs together. ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN SORTED = .false. * SWAP = WR( I ) WR( I ) = WR( I+1 ) WR( I+1 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I+1 ) WI( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF * * ==== Shuffle shifts into pairs of real shifts * . and pairs of complex conjugate shifts * . assuming complex conjugate shifts are * . already adjacent to one another. (Yes, * . they are.) ==== * DO 70 I = KBOT, KS + 2, -2 IF( WI( I ).NE.-WI( I-1 ) ) THEN * SWAP = WR( I ) WR( I ) = WR( I-1 ) WR( I-1 ) = WR( I-2 ) WR( I-2 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I-1 ) WI( I-1 ) = WI( I-2 ) WI( I-2 ) = SWAP END IF 70 CONTINUE END IF * * ==== If there are only two shifts and both are * . real, then use only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( WI( KBOT ).EQ.ZERO ) THEN IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN WR( KBOT-1 ) = WR( KBOT ) ELSE WR( KBOT ) = WR( KBOT-1 ) END IF END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 80 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 90 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR0 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqr1.f000066400000000000000000000116201522610125300261360ustar00rootroot00000000000000*> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * * .. Scalar Arguments .. * DOUBLE PRECISION SI1, SI2, SR1, SR2 * INTEGER LDH, N * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), V( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a *> scalar multiple of the first column of the product *> *> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) *> *> scaling to avoid overflows and most underflows. It *> is assumed that either *> *> 1) sr1 = sr2 and si1 = -si2 *> or *> 2) si1 = si2 = 0. *> *> This is useful for starting double implicit shift bulges *> in the QR algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is integer *> Order of the matrix H. N must be either 2 or 3. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION array of dimension (LDH,N) *> The 2-by-2 or 3-by-3 matrix H in (*). *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> The leading dimension of H as declared in *> the calling procedure. LDH.GE.N *> \endverbatim *> *> \param[in] SR1 *> \verbatim *> SR1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] SI1 *> \verbatim *> SI1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] SR2 *> \verbatim *> SR2 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] SI2 *> \verbatim *> SI2 is DOUBLE PRECISION *> The shifts in (*). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array of dimension N *> A scalar multiple of the first column of the *> matrix K in (*). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION SI1, SI2, SR1, SR2 INTEGER LDH, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), V( * ) * .. * * ================================================================ * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION H21S, H31S, S * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. IF( N.EQ.2 ) THEN S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO ELSE H21S = H( 2, 1 ) / S V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) END IF ELSE S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + $ ABS( H( 3, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO V( 3 ) = ZERO ELSE H21S = H( 2, 1 ) / S H31S = H( 3, 1 ) / S V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + $ H( 2, 3 )*H31S V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + $ H21S*H( 3, 2 ) END IF END IF END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqr2.f000066400000000000000000000510301522610125300261360ustar00rootroot00000000000000*> \brief \b DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR2 is identical to DLAQR3 except that it avoids *> recursion by calling DLAHQR instead of DLAQR4. *> *> Aggressive early deflation: *> *> This subroutine accepts as input an upper Hessenberg matrix *> H and performs an orthogonal similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an orthogonal similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the quasi-triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the orthogonal matrix Z is updated so *> so that the orthogonal Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the orthogonal matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by an orthogonal *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SR *> \verbatim *> SR is DOUBLE PRECISION array, dimension (KBOT) *> \endverbatim *> *> \param[out] SI *> \verbatim *> SI is DOUBLE PRECISION array, dimension (KBOT) *> On output, the real and imaginary parts of approximate *> eigenvalues that may be used for shifts are stored in *> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and *> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. *> The real and imaginary parts of converged eigenvalues *> are stored in SR(KBOT-ND+1) through SR(KBOT) and *> SI(KBOT-ND+1) through SI(KBOT), respectively. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is DOUBLE PRECISION array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; DLAQR2 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.7.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 IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), $ V( LDV, * ), WORK( * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, $ LWKOPT LOGICAL BULGE, SORTED * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to DGEHRD ==== * CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to DORMHR ==== * CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = JW + MAX( LWK1, LWK2 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SR( KWTOP ) = H( KWTOP, KWTOP ) SI( KWTOP ) = ZERO NS = 1 ND = 0 IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) $ THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) * * ==== DTREXC needs a clean margin near the diagonal ==== * DO 10 J = 1, JW - 3 T( J+2, J ) = ZERO T( J+3, J ) = ZERO 10 CONTINUE IF( JW.GT.2 ) $ T( JW, JW-2 ) = ZERO * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 20 CONTINUE IF( ILST.LE.NS ) THEN IF( NS.EQ.1 ) THEN BULGE = .FALSE. ELSE BULGE = T( NS, NS-1 ).NE.ZERO END IF * * ==== Small spike tip test for deflation ==== * IF( .NOT.BULGE ) THEN * * ==== Real eigenvalue ==== * FOO = ABS( T( NS, NS ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 1 ELSE * * ==== Undeflatable. Move it up out of the way. * . (DTREXC can not fail in this case.) ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 1 END IF ELSE * * ==== Complex conjugate pair ==== * FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* $ SQRT( ABS( T( NS-1, NS ) ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. $ MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 2 ELSE * * ==== Undeflatable. Move them up out of the way. * . Fortunately, DTREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 2 END IF END IF * * ==== End deflation detection loop ==== * GO TO 20 END IF * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting diagonal blocks of T improves accuracy for * . graded matrices. Bubble sort deals well with * . exchange failures. ==== * SORTED = .false. I = NS + 1 30 CONTINUE IF( SORTED ) $ GO TO 50 SORTED = .true. * KEND = I - 1 I = INFQR + 1 IF( I.EQ.NS ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF 40 CONTINUE IF( K.LE.KEND ) THEN IF( K.EQ.I+1 ) THEN EVI = ABS( T( I, I ) ) ELSE EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* $ SQRT( ABS( T( I, I+1 ) ) ) END IF * IF( K.EQ.KEND ) THEN EVK = ABS( T( K, K ) ) ELSE IF( T( K+1, K ).EQ.ZERO ) THEN EVK = ABS( T( K, K ) ) ELSE EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* $ SQRT( ABS( T( K, K+1 ) ) ) END IF * IF( EVI.GE.EVK ) THEN I = K ELSE SORTED = .false. IFST = I ILST = K CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST ELSE I = K END IF END IF IF( I.EQ.KEND ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF GO TO 40 END IF GO TO 30 50 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * I = JW 60 CONTINUE IF( I.GE.INFQR+1 ) THEN IF( I.EQ.INFQR+1 ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE AA = T( I-1, I-1 ) CC = T( I, I-1 ) BB = T( I-1, I ) DD = T( I, I ) CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), $ SI( KWTOP+I-1 ), CS, SN ) I = I - 2 END IF GO TO 60 END IF * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL DCOPY( NS, V, LDV, WORK, 1 ) BETA = WORK( 1 ) CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 70 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 80 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 80 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 90 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR2 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqr3.f000066400000000000000000000517101522610125300261440ustar00rootroot00000000000000*> \brief \b DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Aggressive early deflation: *> *> DLAQR3 accepts as input an upper Hessenberg matrix *> H and performs an orthogonal similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an orthogonal similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the quasi-triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the orthogonal matrix Z is updated so *> so that the orthogonal Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the orthogonal matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by an orthogonal *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SR *> \verbatim *> SR is DOUBLE PRECISION array, dimension (KBOT) *> \endverbatim *> *> \param[out] SI *> \verbatim *> SI is DOUBLE PRECISION array, dimension (KBOT) *> On output, the real and imaginary parts of approximate *> eigenvalues that may be used for shifts are stored in *> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and *> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. *> The real and imaginary parts of converged eigenvalues *> are stored in SR(KBOT-ND+1) through SR(KBOT) and *> SI(KBOT-ND+1) through SI(KBOT), respectively. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is DOUBLE PRECISION array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; DLAQR3 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), $ V( LDV, * ), WORK( * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, $ LWKOPT, NMIN LOGICAL BULGE, SORTED * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER ILAENV EXTERNAL DLAMCH, ILAENV * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR, $ DTREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to DGEHRD ==== * CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to DORMHR ==== * CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to DLAQR4 ==== * CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, $ V, LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SR( KWTOP ) = H( KWTOP, KWTOP ) SI( KWTOP ) = ZERO NS = 1 ND = 0 IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) $ THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) ELSE CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) END IF * * ==== DTREXC needs a clean margin near the diagonal ==== * DO 10 J = 1, JW - 3 T( J+2, J ) = ZERO T( J+3, J ) = ZERO 10 CONTINUE IF( JW.GT.2 ) $ T( JW, JW-2 ) = ZERO * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 20 CONTINUE IF( ILST.LE.NS ) THEN IF( NS.EQ.1 ) THEN BULGE = .FALSE. ELSE BULGE = T( NS, NS-1 ).NE.ZERO END IF * * ==== Small spike tip test for deflation ==== * IF( .NOT. BULGE ) THEN * * ==== Real eigenvalue ==== * FOO = ABS( T( NS, NS ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 1 ELSE * * ==== Undeflatable. Move it up out of the way. * . (DTREXC can not fail in this case.) ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 1 END IF ELSE * * ==== Complex conjugate pair ==== * FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* $ SQRT( ABS( T( NS-1, NS ) ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. $ MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 2 ELSE * * ==== Undeflatable. Move them up out of the way. * . Fortunately, DTREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 2 END IF END IF * * ==== End deflation detection loop ==== * GO TO 20 END IF * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting diagonal blocks of T improves accuracy for * . graded matrices. Bubble sort deals well with * . exchange failures. ==== * SORTED = .false. I = NS + 1 30 CONTINUE IF( SORTED ) $ GO TO 50 SORTED = .true. * KEND = I - 1 I = INFQR + 1 IF( I.EQ.NS ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF 40 CONTINUE IF( K.LE.KEND ) THEN IF( K.EQ.I+1 ) THEN EVI = ABS( T( I, I ) ) ELSE EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* $ SQRT( ABS( T( I, I+1 ) ) ) END IF * IF( K.EQ.KEND ) THEN EVK = ABS( T( K, K ) ) ELSE IF( T( K+1, K ).EQ.ZERO ) THEN EVK = ABS( T( K, K ) ) ELSE EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* $ SQRT( ABS( T( K, K+1 ) ) ) END IF * IF( EVI.GE.EVK ) THEN I = K ELSE SORTED = .false. IFST = I ILST = K CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST ELSE I = K END IF END IF IF( I.EQ.KEND ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF GO TO 40 END IF GO TO 30 50 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * I = JW 60 CONTINUE IF( I.GE.INFQR+1 ) THEN IF( I.EQ.INFQR+1 ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE AA = T( I-1, I-1 ) CC = T( I, I-1 ) BB = T( I-1, I ) DD = T( I, I ) CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), $ SI( KWTOP+I-1 ), CS, SN ) I = I - 2 END IF GO TO 60 END IF * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL DCOPY( NS, V, LDV, WORK, 1 ) BETA = WORK( 1 ) CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 70 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 80 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 80 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 90 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR3 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqr4.f000066400000000000000000000643101522610125300261450ustar00rootroot00000000000000*> \brief \b DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR4 implements one level of recursion for DLAQR0. *> It is a complete implementation of the small bulge multi-shift *> QR algorithm. It may be called by DLAQR0 and, for large enough *> deflation window size, it may be called by DLAQR3. This *> subroutine is identical to DLAQR0 except that it calls DLAQR2 *> instead of DLAQR3. *> *> DLAQR4 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**T, where T is an upper quasi-triangular matrix (the *> Schur form), and Z is the orthogonal matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input orthogonal *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to DGEBAL, and then passed to DGEHRD when the *> matrix output by DGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H contains *> the upper quasi-triangular matrix T from the Schur *> decomposition (the Schur form); 2-by-2 diagonal blocks *> (corresponding to complex conjugate pairs of eigenvalues) *> are returned in standard form, with H(i,i) = H(i+1,i+1) *> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (IHI) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (IHI) *> The real and imaginary parts, respectively, of the computed *> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) *> and WI(ILO:IHI). If two eigenvalues are computed as a *> complex conjugate pair, they are stored in consecutive *> elements of WR and WI, say the i-th and (i+1)th, with *> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then *> the eigenvalues are stored in the same order as on the *> diagonal of the Schur form returned in H, with *> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal *> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and *> WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then DLAQR4 does a workspace query. *> In this case, DLAQR4 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, DLAQR4 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a orthogonal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== DOUBLE PRECISION WILK1, WILK2 PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. DOUBLE PRECISION ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use DLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to DLAQR2 ==== * CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, $ N, H, LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== DLAHQR/DLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 80 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 90 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, $ WORK, LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if DLAQR2 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . DLAQR2 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) AA = WILK1*SS + H( I, I ) BB = SS CC = WILK2*SS DD = AA CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) 30 CONTINUE IF( KS.EQ.KTOP ) THEN WR( KS+1 ) = H( KS+1, KS+1 ) WI( KS+1 ) = ZERO WR( KS ) = WR( KS+1 ) WI( KS ) = WI( KS+1 ) END IF ELSE * * ==== Got NS/2 or fewer shifts? Use DLAHQR * . on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) CALL DLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), $ 1, 1, ZDUM, 1, INF ) KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. ==== * IF( KS.GE.KBOT ) THEN AA = H( KBOT-1, KBOT-1 ) CC = H( KBOT, KBOT-1 ) BB = H( KBOT-1, KBOT ) DD = H( KBOT, KBOT ) CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), $ WI( KBOT-1 ), WR( KBOT ), $ WI( KBOT ), CS, SN ) KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) * . Bubble sort keeps complex conjugate * . pairs together. ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN SORTED = .false. * SWAP = WR( I ) WR( I ) = WR( I+1 ) WR( I+1 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I+1 ) WI( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF * * ==== Shuffle shifts into pairs of real shifts * . and pairs of complex conjugate shifts * . assuming complex conjugate shifts are * . already adjacent to one another. (Yes, * . they are.) ==== * DO 70 I = KBOT, KS + 2, -2 IF( WI( I ).NE.-WI( I-1 ) ) THEN * SWAP = WR( I ) WR( I ) = WR( I-1 ) WR( I-1 ) = WR( I-2 ) WR( I-2 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I-1 ) WI( I-1 ) = WI( I-2 ) WI( I-2 ) = SWAP END IF 70 CONTINUE END IF * * ==== If there are only two shifts and both are * . real, then use only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( WI( KBOT ).EQ.ZERO ) THEN IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN WR( KBOT-1 ) = WR( KBOT ) ELSE WR( KBOT ) = WR( KBOT-1 ) END IF END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 80 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 90 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR4 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaqr5.f000066400000000000000000001020721522610125300261440ustar00rootroot00000000000000*> \brief \b DLAQR5 performs a single small-bulge multi-shift QR sweep. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), * $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR5, called by DLAQR0, performs a *> single small-bulge multi-shift QR sweep. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is logical scalar *> WANTT = .true. if the quasi-triangular Schur factor *> is being computed. WANTT is set to .false. otherwise. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is logical scalar *> WANTZ = .true. if the orthogonal Schur factor is being *> computed. WANTZ is set to .false. otherwise. *> \endverbatim *> *> \param[in] KACC22 *> \verbatim *> KACC22 is integer with value 0, 1, or 2. *> Specifies the computation mode of far-from-diagonal *> orthogonal updates. *> = 0: DLAQR5 does not accumulate reflections and does not *> use matrix-matrix multiply to update far-from-diagonal *> matrix entries. *> = 1: DLAQR5 accumulates reflections and uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries. *> = 2: DLAQR5 accumulates reflections, uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries, *> and takes advantage of 2-by-2 block structure during *> matrix multiplies. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is integer scalar *> N is the order of the Hessenberg matrix H upon which this *> subroutine operates. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is integer scalar *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is integer scalar *> These are the first and last rows and columns of an *> isolated diagonal block upon which the QR sweep is to be *> applied. It is assumed without a check that *> either KTOP = 1 or H(KTOP,KTOP-1) = 0 *> and *> either KBOT = N or H(KBOT+1,KBOT) = 0. *> \endverbatim *> *> \param[in] NSHFTS *> \verbatim *> NSHFTS is integer scalar *> NSHFTS gives the number of simultaneous shifts. NSHFTS *> must be positive and even. *> \endverbatim *> *> \param[in,out] SR *> \verbatim *> SR is DOUBLE PRECISION array of size (NSHFTS) *> \endverbatim *> *> \param[in,out] SI *> \verbatim *> SI is DOUBLE PRECISION array of size (NSHFTS) *> SR contains the real parts and SI contains the imaginary *> parts of the NSHFTS shifts of origin that define the *> multi-shift QR sweep. On output SR and SI may be *> reordered. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array of size (LDH,N) *> On input H contains a Hessenberg matrix. On output a *> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied *> to the isolated diagonal block in rows and columns KTOP *> through KBOT. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer scalar *> LDH is the leading dimension of H just as declared in the *> calling procedure. LDH.GE.MAX(1,N). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer scalar *> LDA is the leading dimension of Z just as declared in *> the calling procedure. LDZ.GE.N. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array of size (LDV,NSHFTS/2) *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> LDV is the leading dimension of V as declared in the *> calling procedure. LDV.GE.3. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array of size *> (LDU,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is integer scalar *> LDU is the leading dimension of U just as declared in the *> in the calling subroutine. LDU.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> NH is the number of columns in array WH available for *> workspace. NH.GE.1. *> \endverbatim *> *> \param[out] WH *> \verbatim *> WH is DOUBLE PRECISION array of size (LDWH,NH) *> \endverbatim *> *> \param[in] LDWH *> \verbatim *> LDWH is integer scalar *> Leading dimension of WH just as declared in the *> calling procedure. LDWH.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer scalar *> NV is the number of rows in WV agailable for workspace. *> NV.GE.1. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is DOUBLE PRECISION array of size *> (LDWV,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer scalar *> LDWV is the leading dimension of WV as declared in the *> in the calling subroutine. LDWV.GE.NV. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, $ ULP INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, $ NS, NU LOGICAL ACCUM, BLK22, BMP22 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. * INTRINSIC ABS, DBLE, MAX, MIN, MOD * .. * .. Local Arrays .. DOUBLE PRECISION VT( 3 ) * .. * .. External Subroutines .. EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, $ DTRMM * .. * .. Executable Statements .. * * ==== If there are no shifts, then there is nothing to do. ==== * IF( NSHFTS.LT.2 ) $ RETURN * * ==== If the active block is empty or 1-by-1, then there * . is nothing to do. ==== * IF( KTOP.GE.KBOT ) $ RETURN * * ==== Shuffle shifts into pairs of real shifts and pairs * . of complex conjugate shifts assuming complex * . conjugate shifts are already adjacent to one * . another. ==== * DO 10 I = 1, NSHFTS - 2, 2 IF( SI( I ).NE.-SI( I+1 ) ) THEN * SWAP = SR( I ) SR( I ) = SR( I+1 ) SR( I+1 ) = SR( I+2 ) SR( I+2 ) = SWAP * SWAP = SI( I ) SI( I ) = SI( I+1 ) SI( I+1 ) = SI( I+2 ) SI( I+2 ) = SWAP END IF 10 CONTINUE * * ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. The shuffle above * . ensures that the dropped shift is real and that * . the remaining shifts are paired. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) * * ==== Machine constants for deflation ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Use accumulated reflections to update far-from-diagonal * . entries ? ==== * ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) * * ==== If so, exploit the 2-by-2 block structure? ==== * BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) * * ==== clear trash ==== * IF( KTOP+2.LE.KBOT ) $ H( KTOP+2, KTOP ) = ZERO * * ==== NBMPS = number of 2-shift bulges in the chain ==== * NBMPS = NS / 2 * * ==== KDU = width of slab ==== * KDU = 6*NBMPS - 3 * * ==== Create and chase chains of NBMPS bulges ==== * DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 NDCOL = INCOL + KDU IF( ACCUM ) $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) * * ==== Near-the-diagonal bulge chase. The following loop * . performs the near-the-diagonal part of a small bulge * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal * . chunk extends from column INCOL to column NDCOL * . (including both column INCOL and column NDCOL). The * . following loop chases a 3*NBMPS column long chain of * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL * . may be less than KTOP and and NDCOL may be greater than * . KBOT indicating phantom columns from which to chase * . bulges before they are actually introduced or to which * . to chase bulges beyond column KBOT.) ==== * DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) * * ==== Bulges number MTOP to MBOT are active double implicit * . shift bulges. There may or may not also be small * . 2-by-2 bulge, if there is room. The inactive bulges * . (if any) must wait until the active bulges have moved * . down the diagonal to make room. The phantom matrix * . paradigm described above helps keep track. ==== * MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) M22 = MBOT + 1 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. $ ( KBOT-2 ) * * ==== Generate reflections to chase the chain right * . one column. (The minimum value of K is KTOP-1.) ==== * DO 20 M = MTOP, MBOT K = KRCOL + 3*( M-1 ) IF( K.EQ.KTOP-1 ) THEN CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ V( 1, M ) ) ALPHA = V( 1, M ) CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) ELSE BETA = H( K+1, K ) V( 2, M ) = H( K+2, K ) V( 3, M ) = H( K+3, K ) CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant * . deflation or destructive underflow. In the * . underflow case, try the two-small-subdiagonals * . trick to try to reinflate the bulge. ==== * IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Atypical case: collapsed. Attempt to * . reintroduce ignoring H(K+1,K) and H(K+2,K). * . If the fill resulting from the new * . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ VT ) ALPHA = VT( 1 ) CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* $ H( K+2, K ) ) * IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ $ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would * . create non-negligible fill. Use * . the old one with trepidation. ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would * . create only negligible fill. * . Replace the old reflector with * . the new one. ==== * H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) V( 2, M ) = VT( 2 ) V( 3, M ) = VT( 3 ) END IF END IF END IF 20 CONTINUE * * ==== Generate a 2-by-2 reflection, if needed. ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF( K.EQ.KTOP-1 ) THEN CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), $ V( 1, M22 ) ) BETA = V( 1, M22 ) CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) ELSE BETA = H( K+1, K ) V( 2, M22 ) = H( K+2, K ) CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF END IF * * ==== Multiply H by reflections from the left ==== * IF( ACCUM ) THEN JBOT = MIN( NDCOL, KBOT ) ELSE IF( WANTT ) THEN JBOT = N ELSE JBOT = KBOT END IF DO 40 J = MAX( KTOP, KRCOL ), JBOT MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) DO 30 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 30 CONTINUE 40 CONTINUE IF( BMP22 ) THEN K = KRCOL + 3*( M22-1 ) DO 50 J = MAX( K+1, KTOP ), JBOT REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* $ H( K+2, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 50 CONTINUE END IF * * ==== Multiply H by reflections from the right. * . Delay filling in the last row until the * . vigilant deflation check is complete. ==== * IF( ACCUM ) THEN JTOP = MAX( KTOP, INCOL ) ELSE IF( WANTT ) THEN JTOP = 1 ELSE JTOP = KTOP END IF DO 90 M = MTOP, MBOT IF( V( 1, M ).NE.ZERO ) THEN K = KRCOL + 3*( M-1 ) DO 60 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) 60 CONTINUE * IF( ACCUM ) THEN * * ==== Accumulate U. (If necessary, update Z later * . with with an efficient matrix-matrix * . multiply.) ==== * KMS = K - INCOL DO 70 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) 70 CONTINUE ELSE IF( WANTZ ) THEN * * ==== U is not accumulated, so update Z * . now by multiplying by reflections * . from the right. ==== * DO 80 J = ILOZ, IHIZ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) 80 CONTINUE END IF END IF 90 CONTINUE * * ==== Special case: 2-by-2 reflection (if needed) ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF ( V( 1, M22 ).NE.ZERO ) THEN DO 100 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* $ H( J, K+2 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) 100 CONTINUE * IF( ACCUM ) THEN KMS = K - INCOL DO 110 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ $ V( 2, M22 )*U( J, KMS+2 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*V( 2, M22 ) 110 CONTINUE ELSE IF( WANTZ ) THEN DO 120 J = ILOZ, IHIZ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* $ Z( J, K+2 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) 120 CONTINUE END IF END IF END IF * * ==== Vigilant deflation check ==== * MSTART = MTOP IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) $ MSTART = MSTART + 1 MEND = MBOT IF( BMP22 ) $ MEND = MEND + 1 IF( KRCOL.EQ.KBOT-2 ) $ MEND = MEND + 1 DO 130 M = MSTART, MEND K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) * * ==== The following convergence test requires that * . the tradition small-compared-to-nearby-diagonals * . criterion and the Ahues & Tisseur (LAWN 122, 1997) * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 * . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) IF( TST1.EQ.ZERO ) THEN IF( K.GE.KTOP+1 ) $ TST1 = TST1 + ABS( H( K, K-1 ) ) IF( K.GE.KTOP+2 ) $ TST1 = TST1 + ABS( H( K, K-2 ) ) IF( K.GE.KTOP+3 ) $ TST1 = TST1 + ABS( H( K, K-3 ) ) IF( K.LE.KBOT-2 ) $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) IF( K.LE.KBOT-3 ) $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) IF( K.LE.KBOT-4 ) $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) END IF IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) $ THEN H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) H11 = MAX( ABS( H( K+1, K+1 ) ), $ ABS( H( K, K )-H( K+1, K+1 ) ) ) H22 = MIN( ABS( H( K+1, K+1 ) ), $ ABS( H( K, K )-H( K+1, K+1 ) ) ) SCL = H11 + H12 TST2 = H22*( H11 / SCL ) * IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO END IF END IF 130 CONTINUE * * ==== Fill in the last row of each bulge. ==== * MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) DO 140 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) H( K+4, K+1 ) = -REFSUM H( K+4, K+2 ) = -REFSUM*V( 2, M ) H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) 140 CONTINUE * * ==== End of near-the-diagonal bulge chase. ==== * 150 CONTINUE * * ==== Use U (if accumulated) to update far-from-diagonal * . entries in H. If required, use U to update Z as * . well. ==== * IF( ACCUM ) THEN IF( WANTT ) THEN JTOP = 1 JBOT = N ELSE JTOP = KTOP JBOT = KBOT END IF IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN * * ==== Updates not exploiting the 2-by-2 block * . structure of U. K1 and NU keep track of * . the location and size of U in the special * . cases of introducing bulges and chasing * . bulges off the bottom. In these special * . cases and in case the number of shifts * . is NS = 2, there is no 2-by-2 block * . structure to exploit. ==== * K1 = MAX( 1, KTOP-INCOL ) NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 * * ==== Horizontal Multiply ==== * DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, $ LDWH ) CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, $ H( INCOL+K1, JCOL ), LDH ) 160 CONTINUE * * ==== Vertical multiply ==== * DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, $ H( JROW, INCOL+K1 ), LDH ) 170 CONTINUE * * ==== Z multiply (also vertical) ==== * IF( WANTZ ) THEN DO 180 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, $ Z( JROW, INCOL+K1 ), LDZ ) 180 CONTINUE END IF ELSE * * ==== Updates exploiting U's 2-by-2 block structure. * . (I2, I4, J2, J4 are the last rows and columns * . of the blocks.) ==== * I2 = ( KDU+1 ) / 2 I4 = KDU J2 = I4 - I2 J4 = KDU * * ==== KZS and KNZ deal with the band of zeros * . along the diagonal of one of the triangular * . blocks. ==== * KZS = ( J4-J2 ) - ( NS+1 ) KNZ = NS + 1 * * ==== Horizontal multiply ==== * DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) * * ==== Copy bottom of H to top+KZS of scratch ==== * (The first KZS rows get multiplied by zero.) ==== * CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), $ LDH, WH( KZS+1, 1 ), LDWH ) * * ==== Multiply by U21**T ==== * CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), $ LDWH ) * * ==== Multiply top of H by U11**T ==== * CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * * ==== Copy top of H to bottom of WH ==== * CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U21**T ==== * CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U22 ==== * CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, $ U( J2+1, I2+1 ), LDU, $ H( INCOL+1+J2, JCOL ), LDH, ONE, $ WH( I2+1, 1 ), LDWH ) * * ==== Copy it back ==== * CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, $ H( INCOL+1, JCOL ), LDH ) 190 CONTINUE * * ==== Vertical multiply ==== * DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) * * ==== Copy right of H to scratch (the first KZS * . columns get multiplied by zero) ==== * CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), $ LDH, WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U21 ==== * CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, $ LDWV ) * * ==== Copy left of H to right of scratch ==== * CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, $ WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U22 ==== * CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ H( JROW, INCOL+1+J2 ), LDH, $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), $ LDWV ) * * ==== Copy it back ==== * CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ H( JROW, INCOL+1 ), LDH ) 200 CONTINUE * * ==== Multiply Z (also vertical) ==== * IF( WANTZ ) THEN DO 210 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) * * ==== Copy right of Z to left of scratch (first * . KZS columns get multiplied by zero) ==== * CALL DLACPY( 'ALL', JLEN, KNZ, $ Z( JROW, INCOL+1+J2 ), LDZ, $ WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U12 ==== * CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, $ LDWV ) CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, $ WV, LDWV ) * * ==== Copy left of Z to right of scratch ==== * CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), $ LDZ, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), $ LDWV ) * * ==== Multiply by U22 ==== * CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ Z( JROW, INCOL+1+J2 ), LDZ, $ U( J2+1, I2+1 ), LDU, ONE, $ WV( 1, 1+I2 ), LDWV ) * * ==== Copy the result back to Z ==== * CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ Z( JROW, INCOL+1 ), LDZ ) 210 CONTINUE END IF END IF END IF 220 CONTINUE * * ==== End of DLAQR5 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlarf.f000066400000000000000000000141101522610125300260370ustar00rootroot00000000000000*> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARF applies a real elementary reflector H to a real m by n matrix *> C, from either the left or the right. H is represented in the form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar and v is a real vector. *> *> If tau = 0, then H is taken to be the unit matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of H. V is not used if *> TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \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, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME INTEGER ILADLR, ILADLC EXTERNAL LSAME, ILADLR, ILADLC * .. * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) LASTV = 0 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end ! of V. IF( APPLYLEFT ) THEN LASTV = M ELSE LASTV = N END IF IF( INCV.GT.0 ) THEN I = 1 + (LASTV-1) * INCV ELSE I = 1 END IF ! Look for the last non-zero row in V. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). LASTC = ILADLC(LASTV, N, C, LDC) ELSE ! Scan for the last non-zero row in C(:,1:lastv). LASTC = ILADLR(M, LASTV, C, LDC) END IF END IF ! Note that lastc.eq.0 renders the BLAS operations null; no special ! case is needed at this level. IF( APPLYLEFT ) THEN * * Form H * C * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) * CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T * CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) * CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, $ V, INCV, ZERO, WORK, 1 ) * * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T * CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of DLARF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlarfb.f000066400000000000000000000513051522610125300262100ustar00rootroot00000000000000*> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFB applies a real block reflector H or its transpose H**T to a *> real m by n matrix C, from either the left or the right. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**T from the Left *> = 'R': apply H or H**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'T': apply H**T (Transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columnwise *> = 'R': Rowwise *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T (= the number of elementary *> reflectors whose product defines the block reflector). *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The matrix V. See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The triangular k by k matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \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 H*C or H**T*C or C*H or C*H**T. *> \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, dimension (LDWORK,K) *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= max(1,N); *> if SIDE = 'R', LDWORK >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2013 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored; the corresponding *> array elements are modified but restored on exit. The rest of the *> array is not used. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**T * V2 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W**T * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * IF( N.GT.K ) THEN * * C1 := C1 - W * V1**T * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**T * V2**T * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2**T * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * IF( M.GT.K ) THEN * * C1 := C1 - V1**T * W**T * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of DLARFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlarfg.f000066400000000000000000000115721522610125300262170ustar00rootroot00000000000000*> \brief \b DLARFG generates an elementary reflector (Householder matrix). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFG generates a real elementary reflector H of order n, such *> that *> *> H * ( alpha ) = ( beta ), H**T * H = I. *> ( x ) ( 0 ) *> *> where alpha and beta are scalars, and x is an (n-1)-element real *> vector. H is represented in the form *> *> H = I - tau * ( 1 ) * ( 1 v**T ) , *> ( v ) *> *> where tau is a real scalar and v is a real (n-1)-element *> vector. *> *> If the elements of x are all zero, then tau = 0 and H is taken to be *> the unit matrix. *> *> Otherwise 1 <= tau <= 2. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the elementary reflector. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> On entry, the value alpha. *> On exit, it is overwritten with the value beta. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension *> (1+(N-2)*abs(INCX)) *> On entry, the vector x. *> On exit, it is overwritten with the vector v. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) KNT = 0 IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) END IF TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * DO 20 J = 1, KNT BETA = BETA*SAFMIN 20 CONTINUE ALPHA = BETA END IF * RETURN * * End of DLARFG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlarft.f000066400000000000000000000240261522610125300262320ustar00rootroot00000000000000*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFT forms the triangular factor T of a real block reflector H *> of order n, which is defined as a product of k elementary reflectors. *> *> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; *> *> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. *> *> If STOREV = 'C', the vector which defines the elementary reflector *> H(i) is stored in the i-th column of the array V, and *> *> H = I - V * T * V**T *> *> If STOREV = 'R', the vector which defines the elementary reflector *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**T * T * V *> \endverbatim * * Arguments: * ========== * *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies the order in which the elementary reflectors are *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): *> = 'C': columnwise *> = 'R': rowwise *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the block reflector H. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the triangular factor T (= the number of *> elementary reflectors). K >= 1. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,N) if STOREV = 'R' *> The matrix V. See further details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The k by k triangular factor T of the block reflector. *> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is *> lower triangular. The rest of the array is not used. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN PREVLASTV = N DO I = 1, K PREVLASTV = MAX( I, PREVLASTV ) IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = 1, I T( J, I ) = ZERO END DO ELSE * * general case * IF( LSAME( STOREV, 'C' ) ) THEN * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( I , J ) 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, $ T( 1, I ), 1 ) ELSE * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) 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 DGEMV( 'No transpose', I-1, J-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, $ T( 1, I ), 1 ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) IF( I.GT.1 ) THEN PREVLASTV = MAX( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF END DO ELSE PREVLASTV = 1 DO I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = I, K T( J, I ) = ZERO END DO ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( N-K+I , J ) 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) * CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, $ T( I+1, I ), 1 ) ELSE * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) 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 * CALL DGEMV( 'No transpose', K-I, N-K+I-J, $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, $ ONE, T( I+1, I ), 1 ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) IF( I.GT.1 ) THEN PREVLASTV = MIN( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF T( I, I ) = TAU( I ) END IF END DO END IF RETURN * * End of DLARFT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlarfx.f000066400000000000000000000454331522610125300262430ustar00rootroot00000000000000*> \brief \b DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFX applies a real elementary reflector H to a real m by n *> matrix C, from either the left or the right. H is represented in the *> form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar and v is a real vector. *> *> If tau = 0, then H is taken to be the unit matrix *> *> This version uses inline code if H has order < 11. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (M) if SIDE = 'L' *> or (N) if SIDE = 'R' *> The vector v in the representation of H. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDA >= (1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> WORK is not referenced if H has order < 11. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER J DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of DLARFX * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlarnv.f000066400000000000000000000112621522610125300262420ustar00rootroot00000000000000*> \brief \b DLARNV returns a vector of random numbers from a uniform or normal distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARNV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER IDIST, N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARNV returns a vector of n random real numbers from a uniform or *> normal distribution. *> \endverbatim * * Arguments: * ========== * *> \param[in] IDIST *> \verbatim *> IDIST is INTEGER *> Specifies the distribution of the random numbers: *> = 1: uniform (0,1) *> = 2: uniform (-1,1) *> = 3: normal (0,1) *> \endverbatim *> *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine calls the auxiliary routine DLARUV to generate random *> real numbers from a uniform (0,1) distribution, in batches of up to *> 128 using vectorisable code. The Box-Muller method is used to *> transform numbers from a uniform to a normal distribution. *> \endverbatim *> * ===================================================================== SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.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 IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) INTEGER LV PARAMETER ( LV = 128 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IL2, IV * .. * .. Local Arrays .. DOUBLE PRECISION U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL DLARUV * .. * .. Executable Statements .. * DO 40 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) IF( IDIST.EQ.3 ) THEN IL2 = 2*IL ELSE IL2 = IL END IF * * Call DLARUV to generate IL2 numbers from a uniform (0,1) * distribution (IL2 <= LV) * CALL DLARUV( ISEED, IL2, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = U( I ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = TWO*U( I ) - ONE 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ COS( TWOPI*U( 2*I ) ) 30 CONTINUE END IF 40 CONTINUE RETURN * * End of DLARNV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlartg.f000066400000000000000000000126131522610125300262320ustar00rootroot00000000000000*> \brief \b DLARTG generates a plane rotation with real cosine and real sine. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARTG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTG( F, G, CS, SN, R ) * * .. Scalar Arguments .. * DOUBLE PRECISION CS, F, G, R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARTG generate a plane rotation so that *> *> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. *> [ -SN CS ] [ G ] [ 0 ] *> *> This is a slower, more accurate version of the BLAS1 routine DROTG, *> with the following other differences: *> F and G are unchanged on return. *> If G=0, then CS=1 and SN=0. *> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any *> floating point operations (saves work in DBDSQR when *> there are zeros on the diagonal). *> *> If F exceeds G in magnitude, CS will be positive. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is DOUBLE PRECISION *> The first component of vector to be rotated. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is DOUBLE PRECISION *> The second component of vector to be rotated. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is DOUBLE PRECISION *> The sine of the rotation. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION *> The nonzero component of the rotated vector. *> *> This version has a few statements commented out for thread safety *> (machine parameters are computed on each entry). 10 feb 03, SJH. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION CS, F, G, R, SN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. * DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * * IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 * FIRST = .FALSE. * END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of DLARTG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaruv.f000066400000000000000000000440721522610125300262560ustar00rootroot00000000000000*> \brief \b DLARUV returns a vector of n random real numbers from a uniform distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARUV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARUV( ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * DOUBLE PRECISION X( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARUV returns a vector of n random real numbers from a uniform (0,1) *> distribution (n <= 128). *> *> This is an auxiliary routine called by DLARNV and ZLARNV. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. N <= 128. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine uses a multiplicative congruential method with modulus *> 2**48 and multiplier 33952834046453 (see G.S.Fishman, *> 'Multiplicative congruential random number generators with modulus *> 2**b: an exhaustive analysis for b = 32 and a partial analysis for *> b = 48', Math. Comp. 189, pp 331-344, 1990). *> *> 48-bit integers are stored in 4 integer array elements with 12 bits *> per element. Hence the routine is portable across machines with *> integers of 32 bits or more. *> \endverbatim *> * ===================================================================== SUBROUTINE DLARUV( ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.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 N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( N ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) INTEGER LV, IPW2 DOUBLE PRECISION R PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J * .. * .. Local Arrays .. INTEGER MM( LV, 4 ) * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN, MOD * .. * .. Data statements .. DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, $ 2549 / DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, $ 1145 / DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, $ 2253 / DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, $ 305 / DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, $ 3301 / DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, $ 1065 / DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, $ 3133 / DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, $ 2913 / DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, $ 3285 / DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, $ 1241 / DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, $ 1197 / DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, $ 3729 / DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, $ 2501 / DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, $ 1673 / DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, $ 541 / DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, $ 2753 / DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, $ 949 / DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, $ 2361 / DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, $ 1165 / DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, $ 4081 / DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, $ 2725 / DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, $ 3305 / DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, $ 3069 / DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, $ 3617 / DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, $ 3733 / DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, $ 409 / DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, $ 2157 / DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, $ 1361 / DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, $ 3973 / DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, $ 1865 / DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, $ 2525 / DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, $ 1409 / DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, $ 3445 / DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, $ 3577 / DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, $ 77 / DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, $ 3761 / DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, $ 2149 / DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, $ 1449 / DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, $ 3005 / DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, $ 225 / DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, $ 85 / DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, $ 3673 / DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, $ 3117 / DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, $ 3089 / DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, $ 1349 / DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, $ 2057 / DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, $ 413 / DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, $ 65 / DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, $ 1845 / DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, $ 697 / DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, $ 3085 / DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, $ 3441 / DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, $ 1573 / DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, $ 3689 / DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, $ 2941 / DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, $ 929 / DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, $ 533 / DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, $ 2841 / DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, $ 4077 / DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, $ 721 / DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, $ 2821 / DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, $ 2249 / DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, $ 2397 / DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, $ 2817 / DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, $ 245 / DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, $ 1913 / DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, $ 1997 / DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, $ 3121 / DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, $ 997 / DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, $ 1833 / DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, $ 2877 / DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, $ 1633 / DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, $ 981 / DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, $ 2009 / DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, $ 941 / DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, $ 2449 / DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, $ 197 / DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, $ 2441 / DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, $ 285 / DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, $ 1473 / DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, $ 2741 / DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, $ 3129 / DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, $ 909 / DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, $ 2801 / DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, $ 421 / DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, $ 4073 / DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, $ 2813 / DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, $ 2337 / DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, $ 1429 / DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, $ 1177 / DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, $ 1901 / DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, $ 81 / DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, $ 1669 / DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, $ 2633 / DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, $ 2269 / DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, $ 129 / DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, $ 1141 / DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, $ 249 / DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, $ 3917 / DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, $ 2481 / DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, $ 3941 / DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, $ 2217 / DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, $ 2749 / DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, $ 3041 / DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, $ 1877 / DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, $ 345 / DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, $ 2861 / DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, $ 1809 / DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, $ 3141 / DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, $ 2825 / DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, $ 157 / DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, $ 2881 / DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, $ 3637 / DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, $ 1465 / DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, $ 2829 / DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, $ 2161 / DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, $ 3365 / DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, $ 361 / DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, $ 2685 / DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, $ 3745 / DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, $ 2325 / DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, $ 3609 / DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, $ 3821 / DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, $ 3537 / DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, $ 517 / DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, $ 3017 / DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, $ 2141 / DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, $ 1537 / * .. * .. Executable Statements .. * I1 = ISEED( 1 ) I2 = ISEED( 2 ) I3 = ISEED( 3 ) 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 * IT4 = I4*MM( I, 4 ) IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + $ I4*MM( I, 1 ) IT1 = MOD( IT1, IPW2 ) * * Convert 48-bit integer to a real number in the interval (0,1) * X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* $ DBLE( IT4 ) ) ) ) * IF (X( I ).EQ.1.0D0) 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 * will occur about once every 2**n calls), then X( I ) will * 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. I1 = I1 + 2 I2 = I2 + 2 I3 = I3 + 2 I4 = I4 + 2 GOTO 20 END IF * 10 CONTINUE * * Return final value of seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 RETURN * * End of DLARUV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlascl.f000066400000000000000000000234271522610125300262240ustar00rootroot00000000000000*> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASCL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASCL multiplies the M by N real matrix A by the real scalar *> CTO/CFROM. This is done without over/underflow as long as the final *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that *> A may be full, upper triangular, lower triangular, upper Hessenberg, *> or banded. *> \endverbatim * * Arguments: * ========== * *> \param[in] TYPE *> \verbatim *> TYPE is CHARACTER*1 *> TYPE indices the storage type of the input matrix. *> = 'G': A is a full matrix. *> = 'L': A is a lower triangular matrix. *> = 'U': A is an upper triangular matrix. *> = 'H': A is an upper Hessenberg matrix. *> = 'B': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the lower *> half stored. *> = 'Q': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the upper *> half stored. *> = 'Z': A is a band matrix with lower bandwidth KL and upper *> bandwidth KU. See DGBTRF for storage details. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The lower bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The upper bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] CFROM *> \verbatim *> CFROM is DOUBLE PRECISION *> \endverbatim *> *> \param[in] CTO *> \verbatim *> CTO is DOUBLE PRECISION *> *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed *> without over/underflow if the final result CTO*A(I,J)/CFROM *> can be represented without over/underflow. CFROM must be *> nonzero. *> \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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The matrix to be multiplied by CTO/CFROM. See TYPE for the *> storage type. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> 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 *> \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 June 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 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 TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME, DISNAN DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN INFO = -4 ELSE IF( DISNAN(CTO) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM IF( CFROM1.EQ.CFROMC ) THEN ! CFROMC is an inf. Multiply by a correctly signed zero for ! finite CTOC, or a NaN if CTOC is infinite. MUL = CTOC / CFROMC DONE = .TRUE. CTO1 = CTOC ELSE CTO1 = CTOC / BIGNUM IF( CTO1.EQ.CTOC ) THEN ! CTOC is either 0 or an inf. In both cases, CTOC itself ! serves as the correct multiplication factor. MUL = CTOC DONE = .TRUE. CFROMC = ONE ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DLASCL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaset.f000066400000000000000000000115611522610125300262320ustar00rootroot00000000000000*> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASET + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N * DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASET initializes an m-by-n matrix A to BETA on the diagonal and *> ALPHA on the offdiagonals. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be set. *> = 'U': Upper triangular part is set; the strictly lower *> triangular part of A is not changed. *> = 'L': Lower triangular part is set; the strictly upper *> triangular part of A is not changed. *> Otherwise: All of the matrix A is set. *> \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] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> The constant to which the offdiagonal elements are to be set. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> The constant to which the diagonal elements are to be set. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On exit, the leading m-by-n submatrix of A is set as follows: *> *> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, *> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, *> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, *> *> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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, M, N DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the strictly upper triangular or trapezoidal part of the * array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the strictly lower triangular or trapezoidal part of the * array to ALPHA. * DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE * ELSE * * Set the leading m-by-n submatrix to ALPHA. * *$omp parallel do private(I) DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE *$omp end parallel do END IF * * Set the first min(M,N) diagonal elements to BETA. * DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE * RETURN * * End of DLASET * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlasr.f000066400000000000000000000353061522610125300260660ustar00rootroot00000000000000*> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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 ) *> ( c(k) s(k) ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( c(k) s(k) ) *> ( 1 ) *> ( ... ) *> ( 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> Specifies whether the plane rotation matrix P is applied to *> A on the left or the right. *> = 'L': Left, compute A := P*A *> = 'R': Right, compute A:= A*P**T *> \endverbatim *> *> \param[in] PIVOT *> \verbatim *> PIVOT is CHARACTER*1 *> Specifies the plane for which P(k) is a plane rotation *> matrix. *> = 'V': Variable pivot, the plane (k,k+1) *> = 'T': Top pivot, the plane (1,k+1) *> = 'B': Bottom pivot, the plane (k,z) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies whether P is a forward or backward sequence of *> plane rotations. *> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) *> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. If m <= 1, an immediate *> return is effected. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. If n <= 1, an *> immediate return is effected. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The cosines c(k) of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The sines s(k) of the plane rotations. The 2-by-2 plane *> rotation part of the matrix P(k), R(k), has the form *> R(k) = ( c(k) s(k) ) *> ( -s(k) c(k) ). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The M-by-N matrix A. On exit, A is overwritten by P*A if *> SIDE = 'R' or by A*P**T if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P**T * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of DLASR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlasrt.f000066400000000000000000000173141522610125300262510ustar00rootroot00000000000000*> \brief \b DLASRT sorts numbers in increasing or decreasing order. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASRT( ID, N, D, INFO ) * * .. Scalar Arguments .. * CHARACTER ID * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Sort the numbers in D in increasing order (if ID = 'I') or *> in decreasing order (if ID = 'D' ). *> *> Use Quick Sort, reverting to Insertion sort on arrays of *> size <= 20. Dimension of STACK limits N to about 2**32. *> \endverbatim * * Arguments: * ========== * *> \param[in] ID *> \verbatim *> ID is CHARACTER*1 *> = 'I': sort D in increasing order; *> = 'D': sort D in decreasing order. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The length of the array D. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the array to be sorted. *> On exit, D has been sorted into increasing order *> (D(1) <= ... <= D(N) ) or into decreasing order *> (D(1) >= ... >= D(N) ), depending on ID. *> \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 June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASRT( ID, N, D, 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..-- * June 2016 * * .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER SELECT PARAMETER ( SELECT = 20 ) * .. * .. Local Scalars .. INTEGER DIR, ENDD, I, J, START, STKPNT DOUBLE PRECISION D1, D2, D3, DMNMX, TMP * .. * .. Local Arrays .. INTEGER STACK( 2, 32 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 DIR = -1 IF( LSAME( ID, 'D' ) ) THEN DIR = 0 ELSE IF( LSAME( ID, 'I' ) ) THEN DIR = 1 END IF IF( DIR.EQ.-1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASRT', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * STKPNT = 1 STACK( 1, 1 ) = 1 STACK( 2, 1 ) = N 10 CONTINUE START = STACK( 1, STKPNT ) ENDD = STACK( 2, STKPNT ) STKPNT = STKPNT - 1 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN * * Do Insertion sort on D( START:ENDD ) * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * DO 30 I = START + 1, ENDD DO 20 J = I, START + 1, -1 IF( D( J ).GT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 30 END IF 20 CONTINUE 30 CONTINUE * ELSE * * Sort into increasing order * DO 50 I = START + 1, ENDD DO 40 J = I, START + 1, -1 IF( D( J ).LT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 50 END IF 40 CONTINUE 50 CONTINUE * END IF * ELSE IF( ENDD-START.GT.SELECT ) THEN * * Partition D( START:ENDD ) and stack parts, largest one first * * Choose partition entry as median of 3 * D1 = D( START ) D2 = D( ENDD ) I = ( START+ENDD ) / 2 D3 = D( I ) IF( D1.LT.D2 ) THEN IF( D3.LT.D1 ) THEN DMNMX = D1 ELSE IF( D3.LT.D2 ) THEN DMNMX = D3 ELSE DMNMX = D2 END IF ELSE IF( D3.LT.D2 ) THEN DMNMX = D2 ELSE IF( D3.LT.D1 ) THEN DMNMX = D3 ELSE DMNMX = D1 END IF END IF * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * I = START - 1 J = ENDD + 1 60 CONTINUE 70 CONTINUE J = J - 1 IF( D( J ).LT.DMNMX ) $ GO TO 70 80 CONTINUE I = I + 1 IF( D( I ).GT.DMNMX ) $ GO TO 80 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 60 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF ELSE * * Sort into increasing order * I = START - 1 J = ENDD + 1 90 CONTINUE 100 CONTINUE J = J - 1 IF( D( J ).GT.DMNMX ) $ GO TO 100 110 CONTINUE I = I + 1 IF( D( I ).LT.DMNMX ) $ GO TO 110 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 90 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF END IF END IF IF( STKPNT.GT.0 ) $ GO TO 10 RETURN * * End of DLASRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlassq.f000066400000000000000000000103611522610125300262420ustar00rootroot00000000000000*> \brief \b DLASSQ updates a sum of squares represented in scaled form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASSQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASSQ returns the values scl and smsq such that *> *> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, *> *> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is *> assumed to be non-negative and scl returns the value *> *> scl = max( scale, abs( x( i ) ) ). *> *> scale and sumsq must be supplied in SCALE and SUMSQ and *> scl and smsq are overwritten on SCALE and SUMSQ respectively. *> *> The routine makes only one pass through the vector x. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements to be used from the vector X. *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> The vector for which a scaled sum of squares is computed. *> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of the vector X. *> INCX > 0. *> \endverbatim *> *> \param[in,out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On entry, the value scale in the equation above. *> On exit, SCALE is overwritten with scl , the scaling factor *> for the sum of squares. *> \endverbatim *> *> \param[in,out] SUMSQ *> \verbatim *> SUMSQ is DOUBLE PRECISION *> On entry, the value sumsq in the equation above. *> On exit, SUMSQ is overwritten with smsq , the basic sum of *> squares from which scl has been factored out. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI * .. * .. External Functions .. LOGICAL DISNAN EXTERNAL DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX ABSXI = ABS( X( IX ) ) IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * End of DLASSQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlasv2.f000066400000000000000000000204511522610125300261470ustar00rootroot00000000000000*> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DLASV2 computes the singular value decomposition of a 2-by-2 *> triangular matrix *> [ F G ] *> [ 0 H ]. *> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the *> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and *> right singular vectors for abs(SSMAX), giving the decomposition *> *> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] *> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is DOUBLE PRECISION *> The (1,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] SSMIN *> \verbatim *> SSMIN is DOUBLE PRECISION *> abs(SSMIN) is the smaller singular value. *> \endverbatim *> *> \param[out] SSMAX *> \verbatim *> SSMAX is DOUBLE PRECISION *> abs(SSMAX) is the larger singular value. *> \endverbatim *> *> \param[out] SNL *> \verbatim *> SNL is DOUBLE PRECISION *> \endverbatim *> *> \param[out] CSL *> \verbatim *> CSL is DOUBLE PRECISION *> The vector (CSL, SNL) is a unit left singular vector for the *> singular value abs(SSMAX). *> \endverbatim *> *> \param[out] SNR *> \verbatim *> SNR is DOUBLE PRECISION *> \endverbatim *> *> \param[out] CSR *> \verbatim *> CSR is DOUBLE PRECISION *> The vector (CSR, SNR) is a unit right singular vector for the *> singular value abs(SSMAX). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Any input parameter may be aliased with any output parameter. *> *> Barring over/underflow and assuming a guard digit in subtraction, all *> output quantities are correct to within a few units in the last *> place (ulps). *> *> In IEEE arithmetic, the code works correctly if one matrix element is *> infinite. *> *> Overflow will not occur unless the largest singular value itself *> overflows or is within a few ulps of overflow. (On machines with *> partial overflow, like the Cray, overflow may occur if the largest *> singular value is within a factor of 2 of overflow.) *> *> Underflow is harmless if underflow is gradual. Otherwise, results *> may correspond to a matrix modified by perturbations of size near *> the underflow threshold. *> \endverbatim *> * ===================================================================== SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION FOUR PARAMETER ( FOUR = 4.0D0 ) * .. * .. Local Scalars .. LOGICAL GASMAL, SWAP INTEGER PMAX DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Executable Statements .. * FT = F FA = ABS( FT ) HT = H HA = ABS( H ) * * PMAX points to the maximum absolute element of matrix * PMAX = 1 if F largest in absolute values * PMAX = 2 if G largest in absolute values * PMAX = 3 if H largest in absolute values * PMAX = 1 SWAP = ( HA.GT.FA ) IF( SWAP ) THEN PMAX = 3 TEMP = FT FT = HT HT = TEMP TEMP = FA FA = HA HA = TEMP * * Now FA .ge. HA * END IF GT = G GA = ABS( GT ) IF( GA.EQ.ZERO ) THEN * * Diagonal matrix * SSMIN = HA SSMAX = FA CLT = ONE CRT = ONE SLT = ZERO SRT = ZERO ELSE GASMAL = .TRUE. IF( GA.GT.FA ) THEN PMAX = 2 IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN * * Case of very large GA * GASMAL = .FALSE. SSMAX = GA IF( HA.GT.ONE ) THEN SSMIN = FA / ( GA / HA ) ELSE SSMIN = ( FA / GA )*HA END IF CLT = ONE SLT = HT / GT SRT = ONE CRT = FT / GT END IF END IF IF( GASMAL ) THEN * * Normal case * D = FA - HA IF( D.EQ.FA ) THEN * * Copes with infinite F or H * L = ONE ELSE L = D / FA END IF * * Note that 0 .le. L .le. 1 * M = GT / FT * * Note that abs(M) .le. 1/macheps * T = TWO - L * * Note that T .ge. 1 * MM = M*M TT = T*T S = SQRT( TT+MM ) * * Note that 1 .le. S .le. 1 + 1/macheps * IF( L.EQ.ZERO ) THEN R = ABS( M ) ELSE R = SQRT( L*L+MM ) END IF * * Note that 0 .le. R .le. 1 + 1/macheps * A = HALF*( S+R ) * * Note that 1 .le. A .le. 1 + abs(M) * SSMIN = HA / A SSMAX = FA*A IF( MM.EQ.ZERO ) THEN * * Note that M is very tiny * IF( L.EQ.ZERO ) THEN T = SIGN( TWO, FT )*SIGN( ONE, GT ) ELSE T = GT / SIGN( D, FT ) + M / T END IF ELSE T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) END IF L = SQRT( T*T+FOUR ) CRT = TWO / L SRT = T / L CLT = ( CRT+SRT*M ) / A SLT = ( HT / FT )*SRT / A END IF END IF IF( SWAP ) THEN CSL = SRT SNL = CRT CSR = SLT SNR = CLT ELSE CSL = CLT SNL = SLT CSR = CRT SNR = SRT END IF * * Correct signs of SSMAX and SSMIN * IF( PMAX.EQ.1 ) $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) IF( PMAX.EQ.2 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) IF( PMAX.EQ.3 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) SSMAX = SIGN( SSMAX, TSIGN ) SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) RETURN * * End of DLASV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlaswp.f000066400000000000000000000117261522610125300262530ustar00rootroot00000000000000*> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASWP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASWP performs a series of row interchanges on the matrix A. *> One row interchange is initiated for each of rows K1 through K2 of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the matrix of column dimension N to which the row *> interchanges will be applied. *> On exit, the permuted matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> \endverbatim *> *> \param[in] K1 *> \verbatim *> K1 is INTEGER *> The first element of IPIV for which a row interchange will *> be done. *> \endverbatim *> *> \param[in] K2 *> \verbatim *> K2 is INTEGER *> (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 (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 *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of IPIV. If IPIV *> is negative, the pivots are applied in reverse order. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by *> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA *> \endverbatim *> * ===================================================================== SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of DLASWP * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlasy2.f000066400000000000000000000343461522610125300261620ustar00rootroot00000000000000*> \brief \b DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION SCALE, XNORM * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in *> *> op(TL)*X + ISGN*X*op(TR) = SCALE*B, *> *> where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or *> -1. op(T) = T or T**T, where T**T denotes the transpose of T. *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRANL *> \verbatim *> LTRANL is LOGICAL *> On entry, LTRANL specifies the op(TL): *> = .FALSE., op(TL) = TL, *> = .TRUE., op(TL) = TL**T. *> \endverbatim *> *> \param[in] LTRANR *> \verbatim *> LTRANR is LOGICAL *> On entry, LTRANR specifies the op(TR): *> = .FALSE., op(TR) = TR, *> = .TRUE., op(TR) = TR**T. *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> On entry, ISGN specifies the sign of the equation *> as described before. ISGN may only be 1 or -1. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> On entry, N1 specifies the order of matrix TL. *> N1 may only be 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> On entry, N2 specifies the order of matrix TR. *> N2 may only be 0, 1 or 2. *> \endverbatim *> *> \param[in] TL *> \verbatim *> TL is DOUBLE PRECISION array, dimension (LDTL,2) *> On entry, TL contains an N1 by N1 matrix. *> \endverbatim *> *> \param[in] LDTL *> \verbatim *> LDTL is INTEGER *> The leading dimension of the matrix TL. LDTL >= max(1,N1). *> \endverbatim *> *> \param[in] TR *> \verbatim *> TR is DOUBLE PRECISION array, dimension (LDTR,2) *> On entry, TR contains an N2 by N2 matrix. *> \endverbatim *> *> \param[in] LDTR *> \verbatim *> LDTR is INTEGER *> The leading dimension of the matrix TR. LDTR >= max(1,N2). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,2) *> On entry, the N1 by N2 matrix B contains the right-hand *> side of the equation. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1,N1). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, SCALE contains the scale factor. SCALE is chosen *> less than or equal to 1 to prevent the solution overflowing. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,2) *> On exit, X contains the N1 by N2 solution. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the matrix X. LDX >= max(1,N1). *> \endverbatim *> *> \param[out] XNORM *> \verbatim *> XNORM is DOUBLE PRECISION *> On exit, XNORM is the infinity-norm of the solution. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, INFO is set to *> 0: successful exit. *> 1: TL and TR have too close eigenvalues, so TL or *> TR is perturbed to get a nonsingular equation. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 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 .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 DOUBLE PRECISION SCALE, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TWO, HALF, EIGHT PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) * .. * .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX * .. * .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / * .. * .. Executable Statements .. * * Do not check the input parameters for errors * INFO = 0 * * Quick return if possible * IF( N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS SGN = ISGN * K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K * * 1 by 1: TL11*X + SGN*X*TR11 = B11 * 10 CONTINUE TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF * SCALE = ONE GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN * * 1 by 2: * TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] * [TR21 TR22] * 20 CONTINUE * SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) IF( LTRANR ) THEN TMP( 2 ) = SGN*TR( 2, 1 ) TMP( 3 ) = SGN*TR( 1, 2 ) ELSE TMP( 2 ) = SGN*TR( 1, 2 ) TMP( 3 ) = SGN*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 * * 2 by 1: * op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] * [TL21 TL22] [X21] [X21] [B21] * 30 CONTINUE SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) IF( LTRANL ) THEN TMP( 2 ) = TL( 1, 2 ) TMP( 3 ) = TL( 2, 1 ) ELSE TMP( 2 ) = TL( 2, 1 ) TMP( 3 ) = TL( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE * * Solve 2 by 2 system using complete pivoting. * Set pivots less than SMIN to SMIN. * IPIV = IDAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF SCALE = ONE IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) END IF RETURN * * 2 by 2: * op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] * [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] * * Solve equivalent 4 by 4 system using complete pivoting. * Set pivots less than SMIN to SMIN. * 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) SMIN = MAX( EPS*SMIN, SMLNUM ) BTMP( 1 ) = ZERO CALL DCOPY( 16, BTMP, 0, T16, 1 ) T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) IF( LTRANL ) THEN T16( 1, 2 ) = TL( 2, 1 ) T16( 2, 1 ) = TL( 1, 2 ) T16( 3, 4 ) = TL( 2, 1 ) T16( 4, 3 ) = TL( 1, 2 ) ELSE T16( 1, 2 ) = TL( 1, 2 ) T16( 2, 1 ) = TL( 2, 1 ) T16( 3, 4 ) = TL( 1, 2 ) T16( 4, 3 ) = TL( 2, 1 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = SGN*TR( 1, 2 ) T16( 2, 4 ) = SGN*TR( 1, 2 ) T16( 3, 1 ) = SGN*TR( 2, 1 ) T16( 4, 2 ) = SGN*TR( 2, 1 ) ELSE T16( 1, 3 ) = SGN*TR( 2, 1 ) T16( 2, 4 ) = SGN*TR( 2, 1 ) T16( 3, 1 ) = SGN*TR( 1, 2 ) T16( 4, 2 ) = SGN*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) * * Perform elimination * DO 100 I = 1, 3 XMAX = ZERO DO 70 IP = I, 4 DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE 70 CONTINUE IF( IPSV.NE.I ) THEN CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE 90 CONTINUE 100 CONTINUE 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. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE 120 CONTINUE DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) RETURN * * End of DLASY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlatdf.f000066400000000000000000000245531522610125300262210ustar00rootroot00000000000000*> \brief \b DLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATDF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) * * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * DOUBLE PRECISION RDSCAL, RDSUM * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION RHS( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATDF uses the LU factorization of the n-by-n matrix Z computed by *> DGETC2 and computes a contribution to the reciprocal Dif-estimate *> by solving Z * x = b for x, and choosing the r.h.s. b such that *> the norm of x is as large as possible. On entry RHS = b holds the *> contribution from earlier solved sub-systems, and on return RHS = x. *> *> The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q, *> where P and Q are permutation matrices. L is lower triangular with *> unit diagonal elements and U is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> IJOB = 2: First compute an approximative null-vector e *> of Z using DGECON, e is normalized and solve for *> 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 chosen as either +1 or -1 (Default). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Z. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix Z computed by DGETC2: Z = P * L * U * Q *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is DOUBLE PRECISION array, dimension (N) *> On entry, RHS contains contributions from other subsystems. *> On exit, RHS contains the solution of the subsystem with *> entries acoording to the value of IJOB (see above). *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is DOUBLE PRECISION *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by DTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is DOUBLE PRECISION *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when DTGSY2 is called by *> DTGSYL. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> This routine is a further developed implementation of algorithm *> BSOLVE in [1] using complete pivoting in the LU factorization. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> *> [1] Bo Kagstrom and Lars Westin, *> Generalized Schur Methods with Condition Estimators for *> Solving the Generalized Sylvester Equation, IEEE Transactions *> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. *> *> [2] Peter Poromaa, *> On Efficient and Robust Estimators for the Separation *> between two Regular Matrix Pairs with Applications in *> Condition Estimation. Report IMINF-95.05, Departement of *> Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. *> \endverbatim *> * ===================================================================== SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER IJOB, LDZ, N DOUBLE PRECISION RDSCAL, RDSUM * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) DOUBLE PRECISION RHS( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXDIM PARAMETER ( MAXDIM = 8 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J, K DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP * .. * .. Local Arrays .. INTEGER IWORK( MAXDIM ) DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP, $ DSCAL * .. * .. External Functions .. DOUBLE PRECISION DASUM, DDOT EXTERNAL DASUM, DDOT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( IJOB.NE.2 ) THEN * * Apply permutations IPIV to RHS * CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) * * Solve for L-part choosing RHS either to +1 or -1. * PMONE = -ONE * DO 10 J = 1, N - 1 BP = RHS( J ) + ONE BM = RHS( J ) - ONE SPLUS = ONE * * Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and * SMIN computed more efficiently than in BSOLVE [1]. * SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 ) SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) SPLUS = SPLUS*RHS( J ) IF( SPLUS.GT.SMINU ) THEN RHS( J ) = BP ELSE IF( SMINU.GT.SPLUS ) THEN RHS( J ) = BM ELSE * * In this case the updating sums are equal and we can * choose RHS(J) +1 or -1. The first time this happens * we choose -1, thereafter +1. This is a simple way to * get good estimates of matrices like Byers well-known * example (see [1]). (Not done in BSOLVE.) * RHS( J ) = RHS( J ) + PMONE PMONE = ONE END IF * * Compute the remaining r.h.s. * TEMP = -RHS( J ) CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) * 10 CONTINUE * * Solve for U-part, look-ahead for RHS(N) = +-1. This is not done * in BSOLVE and will hopefully give us a better estimate because * any ill-conditioning of the original matrix is transfered to U * and not to L. U(N, N) is an approximation to sigma_min(LU). * CALL DCOPY( N-1, RHS, 1, XP, 1 ) XP( N ) = RHS( N ) + ONE RHS( N ) = RHS( N ) - ONE SPLUS = ZERO SMINU = ZERO DO 30 I = N, 1, -1 TEMP = ONE / Z( I, I ) XP( I ) = XP( I )*TEMP RHS( I ) = RHS( I )*TEMP DO 20 K = I + 1, N XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP ) RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) 20 CONTINUE SPLUS = SPLUS + ABS( XP( I ) ) SMINU = SMINU + ABS( RHS( I ) ) 30 CONTINUE IF( SPLUS.GT.SMINU ) $ CALL DCOPY( N, XP, 1, RHS, 1 ) * * Apply the permutations JPIV to the computed solution (RHS) * CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) * * Compute the sum of squares * CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) * ELSE * * IJOB = 2, Compute approximate nullvector XM of Z * CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO ) CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 ) * * Compute RHS * CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) ) CALL DSCAL( N, TEMP, XM, 1 ) CALL DCOPY( N, XM, 1, XP, 1 ) CALL DAXPY( N, ONE, RHS, 1, XP, 1 ) CALL DAXPY( N, -ONE, XM, 1, RHS, 1 ) CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP ) CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP ) IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) ) $ CALL DCOPY( N, XP, 1, RHS, 1 ) * * Compute the sum of squares * CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) * END IF * RETURN * * End of DLATDF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlatrs.f000066400000000000000000000570071522610125300262540ustar00rootroot00000000000000*> \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATRS solves one of the triangular systems *> *> A *x = s*b or A**T *x = s*b *> *> with scaling to prevent overflow. Here A is an upper or lower *> triangular matrix, A**T denotes the transpose of A, x and b are *> n-element vectors, and s is a scaling factor, usually less than *> or equal to 1, chosen so that the components of x will be less than *> the overflow threshold. If the unscaled problem will not cause *> overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A *> is singular (A(j,j) = 0 for some j), then s is set to 0 and a *> non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T* x = s*b (Transpose) *> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \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) *> The triangular matrix A. If UPLO = 'U', the leading n by n *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading n by n lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max (1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scaling factor s for the triangular system *> A * x = s*b or A**T* x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is DOUBLE PRECISION array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-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 doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, DTRSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic *> algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM ) THEN TSCAL = ONE ELSE TSCAL = ONE / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine DTRSV can be used. * J = IDAMAX( N, X, 1 ) XMAX = ABS( X( J ) ) XBND = XMAX IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 50 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 30 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * M(j) = G(j-1) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 30 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 40 CONTINUE END IF 50 CONTINUE * ELSE * * Compute the growth in A**T * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 80 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 60 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) 60 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 70 CONTINUE END IF 80 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = BIGNUM / XMAX CALL DSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 100 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 90 I = 1, N X( I ) = ZERO 90 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 100 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL DSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = IDAMAX( J-1, X, 1 ) XMAX = ABS( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + IDAMAX( N-J, X( J+1 ), 1 ) XMAX = ABS( X( I ) ) END IF END IF 110 CONTINUE * ELSE * * Solve A**T * x = b * DO 160 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = ABS( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = ABS( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = USCAL / TJJS END IF IF( REC.LT.ONE ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * SUMJ = ZERO IF( USCAL.EQ.ONE ) THEN * * If the scaling needed for A in the dot product is 1, * call DDOT to perform the dot product. * IF( UPPER ) THEN SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 120 I = 1, J - 1 SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 120 CONTINUE ELSE IF( J.LT.N ) THEN DO 130 I = J + 1, N SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.TSCAL ) THEN * * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - SUMJ XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 150 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A**T*x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 150 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - sumj if the dot * product has already been divided by 1/A(j,j). * X( J ) = X( J ) / TJJS - SUMJ END IF XMAX = MAX( XMAX, ABS( X( J ) ) ) 160 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of DLATRS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dlatsqr.f000066400000000000000000000171741522610125300264360ustar00rootroot00000000000000*> \brief \b DLATSQR * * 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 *> a real M-by-N matrix A for M >= N: *> *> A = Q * ( R ), *> ( 0 ) *> *> where: *> *> Q is a M-by-M orthogonal matrix, stored on exit in an implicit *> form in the elements below the digonal of the array A and in *> the elemenst of the array T; *> *> R is an upper-triangular N-by-N matrix, stored on exit in *> the elements on and above the diagonal of the array A. *> *> 0 is a (M-N)-by-N zero matrix, and is not stored. *> *> \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.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- * November 2019 * * .. Scalar Arguments .. INTEGER 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorg2r.f000066400000000000000000000122201522610125300261460ustar00rootroot00000000000000*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORG2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DORG2R generates an m by n real matrix Q with orthonormal columns, *> which is defined as the first n columns of a product of k elementary *> reflectors of order m *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGEQRF in the first k columns of its array *> argument A. *> On exit, the m-by-n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has 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 * * ===================================================================== SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, 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, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORG2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorghr.f000066400000000000000000000146501522610125300262450ustar00rootroot00000000000000*> \brief \b DORGHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DORGHR generates a real orthogonal matrix Q which is defined as the *> product of IHI-ILO elementary reflectors of order N, as returned by *> DGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of DGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by DGEHRD. *> On exit, the N-by-N orthogonal matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEHRD. *> \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. LWORK >= IHI-ILO. *> For optimum performance LWORK >= (IHI-ILO)*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 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL DORGQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of DORGHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorgqr.f000066400000000000000000000176101522610125300262550ustar00rootroot00000000000000*> \brief \b DORGQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DORGQR generates an M-by-N real matrix Q with orthonormal columns, *> which is defined as the first N columns of a product of K elementary *> reflectors of order M *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGEQRF in the first k columns of its array *> argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \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. LWORK >= max(1,N). *> For optimum performance LWORK >= 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 has 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 * * ===================================================================== SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, 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, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorgr2.f000066400000000000000000000123231522610125300261520ustar00rootroot00000000000000*> \brief \b DORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DORGR2 generates an m by n real matrix Q with orthonormal rows, *> which is defined as the last m rows of a product of k elementary *> reflectors of order n *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the (m-k+i)-th row must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGERQF in the last k rows of its array argument *> A. *> On exit, the m by n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has 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 * * ===================================================================== SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, 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, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows 1:m-k to rows of the unit matrix * DO 20 J = 1, N DO 10 L = 1, M - K A( L, J ) = ZERO 10 CONTINUE IF( J.GT.N-M .AND. J.LE.N-K ) $ A( M-N+J, J ) = ONE 20 CONTINUE END IF * DO 40 I = 1, K II = M - K + I * * Apply H(i) to A(1:m-k+i,1:n-k+i) from the right * A( II, N-M+II ) = ONE CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ), $ A, LDA, WORK ) CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - TAU( I ) * * Set A(m-k+i,n-k+i+1:n) to zero * DO 30 L = N - M + II + 1, N A( II, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORGR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorgrq.f000066400000000000000000000177211522610125300262600ustar00rootroot00000000000000*> \brief \b DORGRQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGRQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> DORGRQ generates an M-by-N real matrix Q with orthonormal rows, *> which is defined as the last M rows of a product of K elementary *> reflectors of order N *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the (m-k+i)-th row must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGERQF in the last k rows of its array argument *> A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \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. LWORK >= max(1,M). *> For optimum performance LWORK >= M*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 has 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 * * ===================================================================== SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, 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, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORGR2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 ) LWKOPT = M*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGRQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DORGRQ', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGRQ', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk rows are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(1:m-kk,n-kk+1:n) to zero. * DO 20 J = N - KK + 1, N DO 10 I = 1, M - KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) II = M - K + I IF( II.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, $ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H**T to A(1:m-k+i-1,1:n-k+i+ib-1) from the right * CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise', $ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK, $ LDWORK, A, LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H**T to columns 1:n-k+i+ib-1 of current block * CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ), $ WORK, IINFO ) * * Set columns n-k+i+ib:n of current block to zero * DO 40 L = N - K + I + IB, N DO 30 J = II, II + IB - 1 A( J, L ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGRQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorgtsqr.f000066400000000000000000000220131522610125300266150ustar00rootroot00000000000000*> \brief \b DORGTSQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGTSQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> * Definition: * =========== * * SUBROUTINE DORGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, * $ INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) * .. * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, *> which are the first N columns of a product of real orthogonal *> matrices of order M which are returned by DLATSQR *> *> Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). *> *> See the documentation for DLATSQR. *> \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 used by DLATSQR to return *> arrays A and T. MB > N. *> (Note that if MB > M, then M is used instead of MB *> as the row block size). *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The column block size used by DLATSQR to return *> arrays A and T. NB >= 1. *> (Note that if NB > N, then N is used instead of NB *> as the column block size). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> *> On entry: *> *> The elements on and above the diagonal are not accessed. *> The elements below the diagonal represent the unit *> lower-trapezoidal blocked matrix V computed by DLATSQR *> that defines the input matrices Q_in(k) (ones on the *> diagonal are not stored) (same format as the output A *> below the diagonal in DLATSQR). *> *> On exit: *> *> The array A contains an M-by-N orthonormal matrix Q_out, *> i.e the columns of A are orthogonal unit vectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, *> dimension (LDT, N * NIRB) *> where NIRB = Number_of_input_row_blocks *> = MAX( 1, CEIL((M-N)/(MB-N)) ) *> Let NICB = Number_of_input_col_blocks *> = CEIL(N/NB) *> *> The upper-triangular block reflectors used to define the *> input matrices Q_in(k), k=(1:NIRB*NICB). The block *> reflectors are stored in compact form in NIRB block *> reflector sequences. Each of NIRB block reflector sequences *> is stored in a larger NB-by-N column block of T and consists *> of NICB smaller NB-by-NB upper-triangular column blocks. *> (same format as the output T in DLATSQR). *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= max(1,min(NB1,N)). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> (workspace) DOUBLE PRECISION array, dimension (MAX(2,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> The dimension of the array WORK. LWORK >= (M+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. * *> \date November 2019 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> \verbatim *> *> November 2019, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> *> \endverbatim * * ===================================================================== SUBROUTINE DORGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, $ INFO ) IMPLICIT NONE * * -- LAPACK computational routine (version 3.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2019 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER IINFO, LDC, LWORKOPT, LC, LW, NBLOCAL, J * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAMTSQR, DLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * LQUERY = LWORK.EQ.-1 INFO = 0 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 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDT.LT.MAX( 1, MIN( NB, N ) ) ) THEN INFO = -8 ELSE * * Test the input LWORK for the dimension of the array WORK. * This workspace is used to store array C(LDC, N) and WORK(LWORK) * in the call to DLAMTSQR. See the documentation for DLAMTSQR. * IF( LWORK.LT.2 .AND. (.NOT.LQUERY) ) THEN INFO = -10 ELSE * * Set block size for column blocks * NBLOCAL = MIN( NB, N ) * * LWORK = -1, then set the size for the array C(LDC,N) * in DLAMTSQR call and set the optimal size of the work array * WORK(LWORK) in DLAMTSQR call. * LDC = M LC = LDC*N LW = N * NBLOCAL * LWORKOPT = LC+LW * IF( ( LWORK.LT.MAX( 1, LWORKOPT ) ).AND.(.NOT.LQUERY) ) THEN INFO = -10 END IF END IF * END IF * * Handle error in the input parameters and return workspace query. * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGTSQR', -INFO ) RETURN ELSE IF ( LQUERY ) THEN WORK( 1 ) = DBLE( LWORKOPT ) RETURN END IF * * Quick return if possible * IF( MIN( M, N ).EQ.0 ) THEN WORK( 1 ) = DBLE( LWORKOPT ) RETURN END IF * * (1) Form explicitly the tall-skinny M-by-N left submatrix Q1_in * of M-by-M orthogonal matrix Q_in, which is implicitly stored in * the subdiagonal part of input array A and in the input array T. * Perform by the following operation using the routine DLAMTSQR. * * Q1_in = Q_in * ( I ), where I is a N-by-N identity matrix, * ( 0 ) 0 is a (M-N)-by-N zero matrix. * * (1a) Form M-by-N matrix in the array WORK(1:LDC*N) with ones * on the diagonal and zeros elsewhere. * CALL DLASET( 'F', M, N, ZERO, ONE, WORK, LDC ) * * (1b) On input, WORK(1:LDC*N) stores ( I ); * ( 0 ) * * On output, WORK(1:LDC*N) stores Q1_in. * CALL DLAMTSQR( 'L', 'N', M, N, N, MB, NBLOCAL, A, LDA, T, LDT, $ WORK, LDC, WORK( LC+1 ), LW, IINFO ) * * (2) Copy the result from the part of the work array (1:M,1:N) * with the leading dimension LDC that starts at WORK(1) into * the output array A(1:M,1:N) column-by-column. * DO J = 1, N CALL DCOPY( M, WORK( (J-1)*LDC + 1 ), 1, A( 1, J ), 1 ) END DO * WORK( 1 ) = DBLE( LWORKOPT ) RETURN * * End of DORGTSQR * ENDqrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorm22.f000066400000000000000000000326031522610125300260630ustar00rootroot00000000000000*> \brief \b DORM22 multiplies a general matrix by a banded orthogonal matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORM22 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, * $ WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO * .. * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * ) * .. * *> \par Purpose * ============ *> *> \verbatim *> *> *> DORM22 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 of order NQ, with NQ = M if *> SIDE = 'L' and NQ = N if SIDE = 'R'. *> The orthogonal matrix Q processes a 2-by-2 block structure *> *> [ Q11 Q12 ] *> Q = [ ] *> [ Q21 Q22 ], *> *> where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an *> N2-by-N2 upper triangular matrix. *> \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': apply Q (No transpose); *> = 'C': apply Q**T (Conjugate transpose). *> \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] N1 *> \param[in] N2 *> \verbatim *> N1 is INTEGER *> N2 is INTEGER *> The dimension of Q12 and Q21, respectively. N1, N2 >= 0. *> The following requirement must be satisfied: *> N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. *> \endverbatim *> *> \param[in] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension *> (LDQ,M) if SIDE = 'L' *> (LDQ,N) if SIDE = 'R' *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= M*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. * *> \date January 2015 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE DORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, $ WORK, LWORK, 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..-- * January 2015 * IMPLICIT NONE * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DTRMM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q; * NW is the minimum dimension of WORK. * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF NW = NQ IF( N1.EQ.0 .OR. N2.EQ.0 ) NW = 1 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) $ THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( N1.LT.0 .OR. N1+N2.NE.NQ ) THEN INFO = -5 ELSE IF( N2.LT.0 ) THEN INFO = -6 ELSE IF( LDQ.LT.MAX( 1, NQ ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN LWKOPT = M*N WORK( 1 ) = DBLE( LWKOPT ) END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM22', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Degenerate cases (N1 = 0 or N2 = 0) are handled using DTRMM. * IF( N1.EQ.0 ) THEN CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-Unit', M, N, ONE, $ Q, LDQ, C, LDC ) WORK( 1 ) = ONE RETURN ELSE IF( N2.EQ.0 ) THEN CALL DTRMM( SIDE, 'Lower', TRANS, 'Non-Unit', M, N, ONE, $ Q, LDQ, C, LDC ) WORK( 1 ) = ONE RETURN END IF * * Compute the largest chunk size available from the workspace. * NB = MAX( 1, MIN( LWORK, LWKOPT ) / NQ ) * IF( LEFT ) THEN IF( NOTRAN ) THEN DO I = 1, N, NB LEN = MIN( NB, N-I+1 ) LDWORK = M * * Multiply bottom part of C by Q12. * CALL DLACPY( 'All', N1, LEN, C( N2+1, I ), LDC, WORK, $ LDWORK ) CALL DTRMM( 'Left', 'Lower', 'No Transpose', 'Non-Unit', $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, WORK, $ LDWORK ) * * Multiply top part of C by Q11. * CALL DGEMM( 'No Transpose', 'No Transpose', N1, LEN, N2, $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, $ LDWORK ) * * Multiply top part of C by Q21. * CALL DLACPY( 'All', N2, LEN, C( 1, I ), LDC, $ WORK( N1+1 ), LDWORK ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, $ WORK( N1+1 ), LDWORK ) * * Multiply bottom part of C by Q22. * CALL DGEMM( 'No Transpose', 'No Transpose', N2, LEN, N1, $ ONE, Q( N1+1, N2+1 ), LDQ, C( N2+1, I ), LDC, $ ONE, WORK( N1+1 ), LDWORK ) * * Copy everything back. * CALL DLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), $ LDC ) END DO ELSE DO I = 1, N, NB LEN = MIN( NB, N-I+1 ) LDWORK = M * * Multiply bottom part of C by Q21**T. * CALL DLACPY( 'All', N2, LEN, C( N1+1, I ), LDC, WORK, $ LDWORK ) CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, WORK, $ LDWORK ) * * Multiply top part of C by Q11**T. * CALL DGEMM( 'Transpose', 'No Transpose', N2, LEN, N1, $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, $ LDWORK ) * * Multiply top part of C by Q12**T. * CALL DLACPY( 'All', N1, LEN, C( 1, I ), LDC, $ WORK( N2+1 ), LDWORK ) CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-Unit', $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, $ WORK( N2+1 ), LDWORK ) * * Multiply bottom part of C by Q22**T. * CALL DGEMM( 'Transpose', 'No Transpose', N1, LEN, N2, $ ONE, Q( N1+1, N2+1 ), LDQ, C( N1+1, I ), LDC, $ ONE, WORK( N2+1 ), LDWORK ) * * Copy everything back. * CALL DLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), $ LDC ) END DO END IF ELSE IF( NOTRAN ) THEN DO I = 1, M, NB LEN = MIN( NB, M-I+1 ) LDWORK = LEN * * Multiply right part of C by Q21. * CALL DLACPY( 'All', LEN, N2, C( I, N1+1 ), LDC, WORK, $ LDWORK ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, WORK, $ LDWORK ) * * Multiply left part of C by Q11. * CALL DGEMM( 'No Transpose', 'No Transpose', LEN, N2, N1, $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, $ LDWORK ) * * Multiply left part of C by Q12. * CALL DLACPY( 'All', LEN, N1, C( I, 1 ), LDC, $ WORK( 1 + N2*LDWORK ), LDWORK ) CALL DTRMM( 'Right', 'Lower', 'No Transpose', 'Non-Unit', $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, $ WORK( 1 + N2*LDWORK ), LDWORK ) * * Multiply right part of C by Q22. * CALL DGEMM( 'No Transpose', 'No Transpose', LEN, N1, N2, $ ONE, C( I, N1+1 ), LDC, Q( N1+1, N2+1 ), LDQ, $ ONE, WORK( 1 + N2*LDWORK ), LDWORK ) * * Copy everything back. * CALL DLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), $ LDC ) END DO ELSE DO I = 1, M, NB LEN = MIN( NB, M-I+1 ) LDWORK = LEN * * Multiply right part of C by Q12**T. * CALL DLACPY( 'All', LEN, N1, C( I, N2+1 ), LDC, WORK, $ LDWORK ) CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-Unit', $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, WORK, $ LDWORK ) * * Multiply left part of C by Q11**T. * CALL DGEMM( 'No Transpose', 'Transpose', LEN, N1, N2, $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, $ LDWORK ) * * Multiply left part of C by Q21**T. * CALL DLACPY( 'All', LEN, N2, C( I, 1 ), LDC, $ WORK( 1 + N1*LDWORK ), LDWORK ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, $ WORK( 1 + N1*LDWORK ), LDWORK ) * * Multiply right part of C by Q22**T. * CALL DGEMM( 'No Transpose', 'Transpose', LEN, N2, N1, $ ONE, C( I, N2+1 ), LDC, Q( N1+1, N2+1 ), LDQ, $ ONE, WORK( 1 + N1*LDWORK ), LDWORK ) * * Copy everything back. * CALL DLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), $ LDC ) END DO END IF END IF * WORK( 1 ) = DBLE( LWKOPT ) RETURN * * End of DORM22 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorm2r.f000066400000000000000000000163221522610125300261630ustar00rootroot00000000000000*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORM2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORM2R overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. 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': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGEQRF in the first k columns of its array argument A. *> A is modified by the routine but restored on exit. *> \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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \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 *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) 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 * * ===================================================================== SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORM2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dormbr.f000066400000000000000000000251531522610125300262450ustar00rootroot00000000000000*> \brief \b DORMBR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMBR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> If VECT = 'Q', DORMBR 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 *> *> If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': P * C C * P *> TRANS = 'T': P**T * C C * P**T *> *> Here Q and P**T are the orthogonal matrices determined by DGEBRD when *> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and *> P**T are defined as products of elementary reflectors H(i) and G(i) *> respectively. *> *> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the *> order of the orthogonal matrix Q or P**T that is applied. *> *> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: *> if nq >= k, Q = H(1) H(2) . . . H(k); *> if nq < k, Q = H(1) H(2) . . . H(nq-1). *> *> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: *> if k < nq, P = G(1) G(2) . . . G(k); *> if k >= nq, P = G(1) G(2) . . . G(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'Q': apply Q or Q**T; *> = 'P': apply P or P**T. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q, Q**T, P or P**T from the Left; *> = 'R': apply Q, Q**T, P or P**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q or P; *> = 'T': Transpose, apply Q**T or P**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 *> If VECT = 'Q', the number of columns in the original *> matrix reduced by DGEBRD. *> If VECT = 'P', the number of rows in the original *> matrix reduced by DGEBRD. *> K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,min(nq,K)) if VECT = 'Q' *> (LDA,nq) if VECT = 'P' *> The vectors which define the elementary reflectors H(i) and *> G(i), whose products determine the matrices Q and P, as *> returned by DGEBRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If VECT = 'Q', LDA >= max(1,nq); *> if VECT = 'P', LDA >= max(1,min(nq,K)). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(nq,K)) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i) or G(i) which determines Q or P, as returned *> by DGEBRD in the array argument TAUQ or TAUP. *> \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 *> or P*C or P**T*C or C*P or C*P**T. *> \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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', 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 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, 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, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMLQ, DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( K.LT.0 ) THEN INFO = -6 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) $ THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * WORK( 1 ) = 1 IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to DGEBRD with nq >= k * CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to DGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to DGEBRD with nq > k * CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to DGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMBR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dormhr.f000066400000000000000000000202601522610125300262450ustar00rootroot00000000000000*> \brief \b DORMHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMHR 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 of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> IHI-ILO elementary reflectors, as returned by DGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \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 C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of DGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and *> ILO = 1 and IHI = 0, if M = 0; *> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and *> ILO = 1 and IHI = 0, if N = 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L' *> (LDA,N) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by DGEHRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEHRD. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', 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 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LEFT = LSAME( SIDE, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) $ THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN INFO = -5 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 ) ELSE NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 ) END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = NH NI = N I1 = ILO + 1 I2 = 1 ELSE MI = M NI = NH I1 = 1 I2 = ILO + 1 END IF * CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) * WORK( 1 ) = LWKOPT RETURN * * End of DORMHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dorml2.f000066400000000000000000000163551522610125300261630ustar00rootroot00000000000000*> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORML2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORML2 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGELQF. 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': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGELQF in the first k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGELQF. *> \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 *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) 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 * * ===================================================================== SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORML2', -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 ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), $ C( IC, JC ), LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORML2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dormlq.f000066400000000000000000000225021522610125300262510ustar00rootroot00000000000000*> \brief \b DORMLQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMLQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMLQ 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(k) . . . H(2) H(1) *> *> as returned by DGELQF. 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; *> = 'T': 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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGELQF 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. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGELQF. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORML2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, $ A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMLQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dormqr.f000066400000000000000000000222411522610125300262570ustar00rootroot00000000000000*> \brief \b DORMQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMQR 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) *> *> as returned by DGEQRF. 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; *> = 'T': 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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGEQRF 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] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dormr2.f000066400000000000000000000162511522610125300261640ustar00rootroot00000000000000*> \brief \b DORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMR2 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. 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': apply Q (No transpose) *> = 'T': apply Q' (Transpose) *> \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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGERQF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \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 *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) 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 * * ===================================================================== SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) * AII = A( I, NQ-K+I ) A( I, NQ-K+I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, $ WORK ) A( I, NQ-K+I ) = AII 10 CONTINUE RETURN * * End of DORMR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dormrq.f000066400000000000000000000225361522610125300262660ustar00rootroot00000000000000*> \brief \b DORMRQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMRQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMRQ 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) *> *> as returned by DGERQF. 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; *> = 'T': 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] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGERQF in the last k rows of its array argument A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, $ MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORMR2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = MAX( 1, N ) ELSE NQ = N NW = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 ELSE NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, $ K, -1 ) ) LWKOPT = NW*NB + TSIZE END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMRQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB, $ A( I, 1 ), LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(1:m-k+i+ib-1,1:n) * MI = M - K + I + IB - 1 ELSE * * H or H**T is applied to C(1:m,1:n-k+i+ib-1) * NI = N - K + I + IB - 1 END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, $ IB, A( I, 1 ), LDA, WORK( IWT ), LDT, C, LDC, $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMRQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dsteqr.f000066400000000000000000000362761522610125300262720ustar00rootroot00000000000000*> \brief \b DSTEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a *> symmetric tridiagonal matrix using the implicit QL or QR method. *> The eigenvectors of a full or band symmetric matrix can also be found *> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to *> tridiagonal form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'V': Compute eigenvalues and eigenvectors of the original *> symmetric matrix. On entry, Z must contain the *> orthogonal matrix used to reduce the original matrix *> to tridiagonal form. *> = 'I': Compute eigenvalues and eigenvectors of the *> tridiagonal matrix. Z is initialized to the identity *> matrix. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', then Z contains the orthogonal *> matrix used in the reduction to tridiagonal form. *> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the *> orthonormal eigenvectors of the original symmetric matrix, *> and if COMPZ = 'I', Z contains the orthonormal eigenvectors *> of the symmetric tridiagonal matrix. *> If COMPZ = '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 *> eigenvectors are desired, then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) *> If COMPZ = 'N', then WORK 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: the algorithm has failed to find all the eigenvalues in *> a total of 30*N iterations; if INFO = i, then i *> elements of E have not converged to zero; on exit, D *> and E contain the elements of a symmetric tridiagonal *> matrix which is orthogonally similar to the original *> matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, 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 COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, $ DLASRT, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = ONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.LT.NMAXIT ) $ GO TO 10 DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE GO TO 190 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF * 190 CONTINUE RETURN * * End of DSTEQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtgevc.f000066400000000000000000001205001522610125300262240ustar00rootroot00000000000000*> \brief \b DTGEVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGEVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGEVC computes some or all of the right and/or left eigenvectors of *> a pair of real matrices (S,P), where S is a quasi-triangular matrix *> and P is upper triangular. Matrix pairs of this type are produced by *> the generalized Schur factorization of a matrix pair (A,B): *> *> A = Q*S*Z**T, B = Q*P*Z**T *> *> as computed by DGGHRD + DHGEQZ. *> *> 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: * ========== * *> \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, *> specified 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. 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 matrices S and P. N >= 0. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (LDS,N) *> The upper quasi-triangular matrix S from a generalized Schur *> factorization, as computed by DHGEQZ. *> \endverbatim *> *> \param[in] LDS *> \verbatim *> LDS is INTEGER *> The leading dimension of array S. LDS >= max(1,N). *> \endverbatim *> *> \param[in] P *> \verbatim *> P is DOUBLE PRECISION array, dimension (LDP,N) *> The upper triangular matrix P from a generalized Schur *> factorization, as computed by DHGEQZ. *> 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks *> of S must be in positive diagonal form. *> \endverbatim *> *> \param[in] LDP *> \verbatim *> LDP is INTEGER *> The leading dimension of array P. LDP >= 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 left Schur vectors returned by DHGEQZ). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of (S,P) 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 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 Z (usually the orthogonal matrix Z *> of right Schur vectors returned by DHGEQZ). *> *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); *> if HOWMNY = 'B' or 'b', the matrix Z*X; *> if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) *> 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 (6*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex *> eigenvalue. *> \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 *> *> Allocation of workspace: *> ---------- -- --------- *> *> WORK( j ) = 1-norm of j-th column of A, above the diagonal *> WORK( N+j ) = 1-norm of j-th column of B, above the diagonal *> WORK( 2*N+1:3*N ) = real part of eigenvector *> WORK( 3*N+1:4*N ) = imaginary part of eigenvector *> WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector *> WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector *> *> Rowwise vs. columnwise solution methods: *> ------- -- ---------- -------- ------- *> *> Finding a generalized eigenvector consists basically of solving the *> singular triangular system *> *> (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) *> *> Consider finding the i-th right eigenvector (assume all eigenvalues *> are real). The equation to be solved is: *> n i *> 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 *> k=j k=j *> *> where C = (A - w B) (The components v(i+1:n) are 0.) *> *> The "rowwise" method is: *> *> (1) v(i) := 1 *> for j = i-1,. . .,1: *> i *> (2) compute s = - sum C(j,k) v(k) and *> k=j+1 *> *> (3) v(j) := s / C(j,j) *> *> Step 2 is sometimes called the "dot product" step, since it is an *> inner product between the j-th row and the portion of the eigenvector *> that has been computed so far. *> *> The "columnwise" method consists basically in doing the sums *> for all the rows in parallel. As each v(j) is computed, the *> contribution of v(j) times the j-th column of C is added to the *> partial sums. Since FORTRAN arrays are stored columnwise, this has *> the advantage that at each step, the elements of C that are accessed *> are adjacent to one another, whereas with the rowwise method, the *> elements accessed at a step are spaced LDS (and LDP) words apart. *> *> When finding left eigenvectors, the matrix in question is the *> transpose of the one in storage, so the rowwise method then *> actually accesses columns of A and B at each step, and so is the *> preferred method. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, 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 HOWMNY, SIDE INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, SAFETY PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ SAFETY = 1.0D+2 ) * .. * .. Local Scalars .. LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK, $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE, $ J, JA, JC, JE, JR, JW, NA, NW DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI, $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A, $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA, $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE, $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX, $ XSCALE * .. * .. Local Arrays .. DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * IF( LSAME( HOWMNY, 'A' ) ) THEN IHWMNY = 1 ILALL = .TRUE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. ELSE IHWMNY = -1 ILALL = .TRUE. END IF * IF( LSAME( SIDE, 'R' ) ) THEN ISIDE = 1 COMPL = .FALSE. COMPR = .TRUE. ELSE IF( LSAME( SIDE, 'L' ) ) THEN ISIDE = 2 COMPL = .TRUE. COMPR = .FALSE. ELSE IF( LSAME( SIDE, 'B' ) ) THEN ISIDE = 3 COMPL = .TRUE. COMPR = .TRUE. ELSE ISIDE = -1 END IF * INFO = 0 IF( ISIDE.LT.0 ) THEN INFO = -1 ELSE IF( IHWMNY.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGEVC', -INFO ) RETURN END IF * * Count the number of eigenvectors to be computed * IF( .NOT.ILALL ) THEN IM = 0 ILCPLX = .FALSE. DO 10 J = 1, N IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 10 END IF IF( J.LT.N ) THEN IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN IF( SELECT( J ) .OR. SELECT( J+1 ) ) $ IM = IM + 2 ELSE IF( SELECT( J ) ) $ IM = IM + 1 END IF 10 CONTINUE ELSE IM = N END IF * * Check 2-by-2 diagonal blocks of A, B * ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 IF( S( J+1, J ).NE.ZERO ) THEN IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF 20 CONTINUE * IF( ILABAD ) THEN INFO = -5 ELSE IF( ILBBAD ) THEN INFO = -7 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN INFO = -12 ELSE IF( MM.LT.IM ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGEVC', -INFO ) RETURN END IF * * Quick return if possible * M = IM IF( N.EQ.0 ) $ RETURN * * Machine Constants * SAFMIN = DLAMCH( 'Safe minimum' ) BIG = ONE / SAFMIN CALL DLABAD( SAFMIN, BIG ) ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) SMALL = SAFMIN*N / ULP BIG = ONE / SMALL BIGNUM = ONE / ( SAFMIN*N ) * * Compute the 1-norm of each column of the strictly upper triangular * part (i.e., excluding all elements belonging to the diagonal * blocks) of A and B to check for possible overflow in the * triangular solver. * ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) $ ANORM = ANORM + ABS( S( 2, 1 ) ) BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND TEMP = TEMP + ABS( S( I, J ) ) TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) TEMP = TEMP + ABS( S( I, J ) ) TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) 50 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) BSCALE = ONE / MAX( BNORM, SAFMIN ) * * Left eigenvectors * IF( COMPL ) THEN IEIG = 0 * * Main loop over eigenvalues * ILCPLX = .FALSE. DO 220 JE = 1, N * * Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or * (b) this would be the second of a complex pair. * Check for complex eigenvalue, so as to be sure of which * entry(-ies) of SELECT to look at. * IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 220 END IF NW = 1 IF( JE.LT.N ) THEN IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF END IF IF( ILALL ) THEN ILCOMP = .TRUE. ELSE IF( ILCPLX ) THEN ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 ) ELSE ILCOMP = SELECT( JE ) END IF IF( .NOT.ILCOMP ) $ GO TO 220 * * Decide if (a) singular pencil, (b) real eigenvalue, or * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * IEIG = IEIG + 1 DO 60 JR = 1, N VL( JR, IEIG ) = ZERO 60 CONTINUE VL( IEIG, IEIG ) = ONE GO TO 220 END IF END IF * * Clear vector * DO 70 JR = 1, NW*N WORK( 2*N+JR ) = ZERO 70 CONTINUE * T * Compute coefficients in ( a A - b B ) y = 0 * a is ACOEF * b is BCOEFR + i*BCOEFI * IF( .NOT.ILCPLX ) THEN * * Real eigenvalue * TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) SALFAR = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO * * Scale to avoid underflow * SCALE = ONE LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. $ SMALL IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), $ ABS( BCOEFR ) ) ) ) IF( LSA ) THEN ACOEF = ASCALE*( SCALE*SBETA ) ELSE ACOEF = SCALE*ACOEF END IF IF( LSB ) THEN BCOEFR = BSCALE*( SCALE*SALFAR ) ELSE BCOEFR = SCALE*BCOEFR END IF END IF ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) * * First component is 1 * WORK( 2*N+JE ) = ONE XMAX = ONE ELSE * * Complex eigenvalue * CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI IF( BCOEFI.EQ.ZERO ) THEN INFO = JE RETURN END IF * * Scale to avoid over/underflow * ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) SCALE = ONE IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) $ SCALE = ( SAFMIN / ULP ) / ACOEFA IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) IF( SAFMIN*ACOEFA.GT.ASCALE ) $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) IF( SAFMIN*BCOEFA.GT.BSCALE ) $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) IF( SCALE.NE.ONE ) THEN ACOEF = SCALE*ACOEF ACOEFA = ABS( ACOEF ) BCOEFR = SCALE*BCOEFR BCOEFI = SCALE*BCOEFI BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) END IF * * Compute first two components of eigenvector * TEMP = ACOEF*S( JE+1, JE ) TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO WORK( 2*N+JE+1 ) = -TEMP2R / TEMP WORK( 3*N+JE+1 ) = -TEMP2I / TEMP ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO TEMP = ACOEF*S( JE, JE+1 ) WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* $ S( JE+1, JE+1 ) ) / TEMP WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) END IF * DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * T * Triangular solve of (a A - b B) y = 0 * * T * (rowwise in (a A - b B) , or columnwise in (a A - b B) ) * IL2BY2 = .FALSE. * DO 160 J = JE + NW, N IF( IL2BY2 ) THEN IL2BY2 = .FALSE. GO TO 160 END IF * NA = 1 BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF * * Check whether scaling is necessary for dot products * XSCALE = ONE / MAX( ONE, XMAX ) TEMP = MAX( WORK( J ), WORK( N+J ), $ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) ) IF( IL2BY2 ) $ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ), $ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) ) IF( TEMP.GT.BIGNUM*XSCALE ) THEN DO 90 JW = 0, NW - 1 DO 80 JR = JE, J - 1 WORK( ( JW+2 )*N+JR ) = XSCALE* $ WORK( ( JW+2 )*N+JR ) 80 CONTINUE 90 CONTINUE XMAX = XMAX*XSCALE END IF * * Compute dot products * * j-1 * SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 * a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close * to underflow. (E.g., less than SMALL.) * * DO 120 JW = 1, NW DO 110 JA = 1, NA SUMS( JA, JW ) = ZERO SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 SUMS( JA, JW ) = SUMS( JA, JW ) + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) SUMP( JA, JW ) = SUMP( JA, JW ) + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE 120 CONTINUE * DO 130 JA = 1, NA IF( ILCPLX ) THEN SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + $ BCOEFR*SUMP( JA, 1 ) - $ BCOEFI*SUMP( JA, 2 ) SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + $ BCOEFR*SUMP( JA, 2 ) + $ BCOEFI*SUMP( JA, 1 ) ELSE SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * * T * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN DO 150 JW = 0, NW - 1 DO 140 JR = JE, J - 1 WORK( ( JW+2 )*N+JR ) = SCALE* $ WORK( ( JW+2 )*N+JR ) 140 CONTINUE 150 CONTINUE XMAX = SCALE*XMAX END IF XMAX = MAX( XMAX, TEMP ) 160 CONTINUE * * Copy eigenvector to VL, back transforming if * HOWMNY='B'. * IEIG = IEIG + 1 IF( ILBACK ) THEN DO 170 JW = 0, NW - 1 CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL, $ WORK( ( JW+2 )*N+JE ), 1, ZERO, $ WORK( ( JW+4 )*N+1 ), 1 ) 170 CONTINUE CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ), $ LDVL ) IBEG = 1 ELSE CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ), $ LDVL ) IBEG = JE END IF * * Scale eigenvector * XMAX = ZERO IF( ILCPLX ) THEN DO 180 J = IBEG, N XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+ $ ABS( VL( J, IEIG+1 ) ) ) 180 CONTINUE ELSE DO 190 J = IBEG, N XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) ) 190 CONTINUE END IF * IF( XMAX.GT.SAFMIN ) THEN XSCALE = ONE / XMAX * DO 210 JW = 0, NW - 1 DO 200 JR = IBEG, N VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW ) 200 CONTINUE 210 CONTINUE END IF IEIG = IEIG + NW - 1 * 220 CONTINUE END IF * * Right eigenvectors * IF( COMPR ) THEN IEIG = IM + 1 * * Main loop over eigenvalues * ILCPLX = .FALSE. DO 500 JE = N, 1, -1 * * Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or * (b) this would be the second of a complex pair. * Check for complex eigenvalue, so as to be sure of which * entry(-ies) of SELECT to look at -- if complex, SELECT(JE) * or SELECT(JE-1). * If this is a complex pair, the 2-by-2 diagonal block * corresponding to the eigenvalue is in rows/columns JE-1:JE * IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 500 END IF NW = 1 IF( JE.GT.1 ) THEN IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF END IF IF( ILALL ) THEN ILCOMP = .TRUE. ELSE IF( ILCPLX ) THEN ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 ) ELSE ILCOMP = SELECT( JE ) END IF IF( .NOT.ILCOMP ) $ GO TO 500 * * Decide if (a) singular pencil, (b) real eigenvalue, or * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * IEIG = IEIG - 1 DO 230 JR = 1, N VR( JR, IEIG ) = ZERO 230 CONTINUE VR( IEIG, IEIG ) = ONE GO TO 500 END IF END IF * * Clear vector * DO 250 JW = 0, NW - 1 DO 240 JR = 1, N WORK( ( JW+2 )*N+JR ) = ZERO 240 CONTINUE 250 CONTINUE * * Compute coefficients in ( a A - b B ) x = 0 * a is ACOEF * b is BCOEFR + i*BCOEFI * IF( .NOT.ILCPLX ) THEN * * Real eigenvalue * TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) SALFAR = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO * * Scale to avoid underflow * SCALE = ONE LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. $ SMALL IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), $ ABS( BCOEFR ) ) ) ) IF( LSA ) THEN ACOEF = ASCALE*( SCALE*SBETA ) ELSE ACOEF = SCALE*ACOEF END IF IF( LSB ) THEN BCOEFR = BSCALE*( SCALE*SALFAR ) ELSE BCOEFR = SCALE*BCOEFR END IF END IF ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) * * First component is 1 * WORK( 2*N+JE ) = ONE XMAX = ONE * * Compute contribution from column JE of A and B to sum * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN INFO = JE - 1 RETURN END IF * * Scale to avoid over/underflow * ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) SCALE = ONE IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) $ SCALE = ( SAFMIN / ULP ) / ACOEFA IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) IF( SAFMIN*ACOEFA.GT.ASCALE ) $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) IF( SAFMIN*BCOEFA.GT.BSCALE ) $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) IF( SCALE.NE.ONE ) THEN ACOEF = SCALE*ACOEF ACOEFA = ABS( ACOEF ) BCOEFR = SCALE*BCOEFR BCOEFI = SCALE*BCOEFI BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) END IF * * Compute first two components of eigenvector * and contribution to sums * TEMP = ACOEF*S( JE, JE-1 ) TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO WORK( 2*N+JE-1 ) = -TEMP2R / TEMP WORK( 3*N+JE-1 ) = -TEMP2I / TEMP ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO TEMP = ACOEF*S( JE-1, JE ) WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* $ S( JE-1, JE-1 ) ) / TEMP WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) ) * * Compute contribution from columns JE and JE-1 * of A and B to the sums. * CREALA = ACOEF*WORK( 2*N+JE-1 ) CIMAGA = ACOEF*WORK( 3*N+JE-1 ) CREALB = BCOEFR*WORK( 2*N+JE-1 ) - $ BCOEFI*WORK( 3*N+JE-1 ) CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) + $ BCOEFR*WORK( 3*N+JE-1 ) CRE2A = ACOEF*WORK( 2*N+JE ) CIM2A = ACOEF*WORK( 3*N+JE ) CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + $ CREALB*P( JR, JE-1 ) - $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + $ CIMAGB*P( JR, JE-1 ) - $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * Columnwise triangular solve of (a A - b B) x = 0 * IL2BY2 = .FALSE. DO 370 J = JE - NW, 1, -1 * * If a 2-by-2 block, is in position j-1:j, wait until * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN * DO 290 JW = 0, NW - 1 DO 280 JR = 1, JE WORK( ( JW+2 )*N+JR ) = SCALE* $ WORK( ( JW+2 )*N+JR ) 280 CONTINUE 290 CONTINUE END IF XMAX = MAX( SCALE*XMAX, TEMP ) * DO 310 JW = 1, NW DO 300 JA = 1, NA WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW ) 300 CONTINUE 310 CONTINUE * * w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * * Check whether scaling is necessary for sum. * XSCALE = ONE / MAX( ONE, XMAX ) TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J ) IF( IL2BY2 ) $ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA* $ WORK( N+J+1 ) ) TEMP = MAX( TEMP, ACOEFA, BCOEFA ) IF( TEMP.GT.BIGNUM*XSCALE ) THEN * DO 330 JW = 0, NW - 1 DO 320 JR = 1, JE WORK( ( JW+2 )*N+JR ) = XSCALE* $ WORK( ( JW+2 )*N+JR ) 320 CONTINUE 330 CONTINUE XMAX = XMAX*XSCALE END IF * * Compute the contributions of the off-diagonals of * column j (and j+1, if 2-by-2 block) of A and B to the * sums. * * DO 360 JA = 1, NA IF( ILCPLX ) THEN CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CIMAGA = ACOEF*WORK( 3*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) - $ BCOEFI*WORK( 3*N+J+JA-1 ) CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) + $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - $ CREALA*S( JR, J+JA-1 ) + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - $ CIMAGA*S( JR, J+JA-1 ) + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - $ CREALA*S( JR, J+JA-1 ) + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE END IF * IL2BY2 = .FALSE. 370 CONTINUE * * Copy eigenvector to VR, back transforming if * HOWMNY='B'. * IEIG = IEIG - NW IF( ILBACK ) THEN * DO 410 JW = 0, NW - 1 DO 380 JR = 1, N WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )* $ VR( JR, 1 ) 380 CONTINUE * * A series of compiler directives to defeat * vectorization for the next loop * * DO 400 JC = 2, JE DO 390 JR = 1, N WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) + $ WORK( ( JW+2 )*N+JC )*VR( JR, JC ) 390 CONTINUE 400 CONTINUE 410 CONTINUE * DO 430 JW = 0, NW - 1 DO 420 JR = 1, N VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR ) 420 CONTINUE 430 CONTINUE * IEND = N ELSE DO 450 JW = 0, NW - 1 DO 440 JR = 1, N VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR ) 440 CONTINUE 450 CONTINUE * IEND = JE END IF * * Scale eigenvector * XMAX = ZERO IF( ILCPLX ) THEN DO 460 J = 1, IEND XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+ $ ABS( VR( J, IEIG+1 ) ) ) 460 CONTINUE ELSE DO 470 J = 1, IEND XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) ) 470 CONTINUE END IF * IF( XMAX.GT.SAFMIN ) THEN XSCALE = ONE / XMAX DO 490 JW = 0, NW - 1 DO 480 JR = 1, IEND VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW ) 480 CONTINUE 490 CONTINUE END IF 500 CONTINUE END IF * RETURN * * End of DTGEVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtgex2.f000066400000000000000000000571261522610125300261620ustar00rootroot00000000000000*> \brief \b DTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGEX2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) *> of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair *> (A, B) by an orthogonal equivalence transformation. *> *> (A, B) must be in generalized real Schur canonical form (as returned *> by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 *> diagonal blocks. B is upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T *> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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, dimensions (LDA,N) *> On entry, the matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \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, dimensions (LDB,N) *> On entry, the matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. *> On exit, the updated matrix Q. *> Not referenced if WANTQ = .FALSE.. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if WANTZ =.TRUE., the orthogonal matrix Z. *> On exit, the updated matrix Z. *> Not referenced if WANTZ = .FALSE.. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index to the first block (A11, B11). 1 <= J1 <= N. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The order of the first block (A11, B11). N1 = 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> The order of the second block (A22, B22). N2 = 0, 1 or 2. *> \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 the array WORK. *> LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit *> >0: If INFO = 1, the transformed matrix (A, B) would be *> too far from generalized Schur form; the blocks are *> not swapped and (A, B) and (Q, Z) are unchanged. *> The problem of swapping is too ill-conditioned. *> <0: If INFO = -16: LWORK is too small. Appropriate value *> for LWORK is returned in WORK(1). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEauxiliary * *> \par Further Details: * ===================== *> *> In the current code both weak and strong stability tests are *> performed. The user can omit the strong stability test by changing *> the internal logical parameter WANDS to .FALSE.. See ref. [2] for *> details. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 WANTQ, WANTZ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * Replaced various illegal calls to DCOPY by calls to DLASET, or by DO * loops. Sven Hammarling, 1/5/02. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TWENTY PARAMETER ( TWENTY = 2.0D+01 ) INTEGER LDST PARAMETER ( LDST = 4 ) LOGICAL WANDS PARAMETER ( WANDS = .TRUE. ) * .. * .. Local Scalars .. LOGICAL DTRONG, WEAK INTEGER I, IDUM, LINFO, M DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS * .. * .. Local Arrays .. INTEGER IWORK( LDST ) DOUBLE PRECISION AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ), $ IRCOP( LDST, LDST ), LI( LDST, LDST ), $ LICOP( LDST, LDST ), S( LDST, LDST ), $ SCPY( LDST, LDST ), T( LDST, LDST ), $ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, DLARTG, $ DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, $ DROT, DSCAL, DTGSY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 ) $ RETURN IF( N1.GT.N .OR. ( J1+N1 ).GT.N ) $ RETURN M = N1 + N2 IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN INFO = -16 WORK( 1 ) = MAX( 1, N*M, M*M*2 ) RETURN END IF * WEAK = .FALSE. DTRONG = .FALSE. * * Make a local copy of selected block * CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST ) CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST ) CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) * * Compute threshold for testing acceptance of swapping. * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS DSCALE = ZERO DSUM = ONE CALL DLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) CALL DLACPY( 'Full', M, M, T, LDST, WORK, M ) CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) DNORM = DSCALE*SQRT( DSUM ) * * THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * on 04/01/10. * "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by * Jim Demmel and Guillaume Revy. See forum post 1783. * THRESH = MAX( TWENTY*EPS*DNORM, SMLNUM ) * IF( M.EQ.2 ) THEN * * CASE 1: Swap 1-by-1 and 1-by-1 blocks. * * Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks * using Givens rotations and perform the swap tentatively. * F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) SB = ABS( T( 2, 2 ) ) SA = ABS( S( 2, 2 ) ) CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM ) IR( 2, 1 ) = -IR( 1, 2 ) IR( 2, 2 ) = IR( 1, 1 ) CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) IF( SA.GE.SB ) THEN CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), $ DDUM ) ELSE CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), $ DDUM ) END IF CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ), $ LI( 2, 1 ) ) CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ), $ LI( 2, 1 ) ) LI( 2, 2 ) = LI( 1, 1 ) LI( 1, 2 ) = -LI( 2, 1 ) * * Weak stability test: * |S21| + |T21| <= O(EPS * F-norm((S, T))) * WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) WEAK = WS.LE.THRESH IF( .NOT.WEAK ) $ GO TO 70 * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL**T*S*QR, B-QL**T*T*QR)) <= O(EPS*F-norm((A,B))) * CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) DSCALE = ZERO DSUM = ONE CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) * CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) DTRONG = SS.LE.THRESH IF( .NOT.DTRONG ) $ GO TO 70 END IF * * Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and * (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). * CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, $ LI( 1, 1 ), LI( 2, 1 ) ) CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, $ LI( 1, 1 ), LI( 2, 1 ) ) * * Set N1-by-N2 (2,1) - blocks to ZERO. * A( J1+1, J1 ) = ZERO B( J1+1, J1 ) = ZERO * * Accumulate transformations into Q and Z if requested. * IF( WANTZ ) $ CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ), $ LI( 2, 1 ) ) * * Exit with INFO = 0 if swap was successfully performed. * RETURN * ELSE * * CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 * and 2-by-2 blocks. * * Solve the generalized Sylvester equation * S11 * R - L * S22 = SCALE * S12 * T11 * R - L * T22 = SCALE * T12 * for R and L. Solutions in LI and IR. * CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST ) CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST, $ IR( N2+1, N1+1 ), LDST ) CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST, $ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ), $ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM, $ LINFO ) * * Compute orthogonal matrix QL: * * QL**T * LI = [ TL ] * [ 0 ] * where * LI = [ -L ] * [ SCALE * identity(N2) ] * DO 10 I = 1, N2 CALL DSCAL( N1, -ONE, LI( 1, I ), 1 ) LI( N1+I, I ) = SCALE 10 CONTINUE CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute orthogonal matrix RQ: * * IR * RQ**T = [ 0 TR], * * where IR = [ SCALE * identity(N1), R ] * DO 20 I = 1, N1 IR( N2+I, I ) = SCALE 20 CONTINUE CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Perform the swapping tentatively: * CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S, $ LDST ) CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T, $ LDST ) CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST ) CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST ) CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST ) CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST ) * * Triangularize the B-part by an RQ factorization. * Apply transformation (from left) to A-part, giving S. * CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK, $ LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK, $ LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute F-norm(S21) in BRQA21. (T21 is 0.) * DSCALE = ZERO DSUM = ONE DO 30 I = 1, N2 CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM ) 30 CONTINUE BRQA21 = DSCALE*SQRT( DSUM ) * * Triangularize the B-part by a QR factorization. * Apply transformation (from right) to A-part, giving S. * CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST, $ WORK, INFO ) CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST, $ WORK, INFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute F-norm(S21) in BQRA21. (T21 is 0.) * DSCALE = ZERO DSUM = ONE DO 40 I = 1, N2 CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM ) 40 CONTINUE BQRA21 = DSCALE*SQRT( DSUM ) * * Decide which method to use. * Weak stability test: * F-norm(S21) <= O(EPS * F-norm((S, T))) * IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST ) CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST ) CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST ) CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST ) ELSE IF( BRQA21.GE.THRESH ) THEN GO TO 70 END IF * * Set lower triangle of B-part to zero * CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL*S*QR**T, B-QL*T*QR**T)) <= O(EPS*F-norm((A,B))) * CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) DSCALE = ZERO DSUM = ONE CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) * CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) DTRONG = ( SS.LE.THRESH ) IF( .NOT.DTRONG ) $ GO TO 70 * END IF * * If the swap is accepted ("weakly" and "strongly"), apply the * transformations and set N1-by-N2 (2,1)-block to zero. * CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) * * copy back M-by-M diagonal block starting at index J1 of (A, B) * CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA ) CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB ) CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST ) * * Standardize existing 2-by-2 blocks. * CALL DLASET( 'Full', M, M, ZERO, ZERO, WORK, M ) WORK( 1 ) = ONE T( 1, 1 ) = ONE IDUM = LWORK - M*M - 2 IF( N2.GT.1 ) THEN CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE, $ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) ) WORK( M+1 ) = -WORK( 2 ) WORK( M+2 ) = WORK( 1 ) T( N2, N2 ) = T( 1, 1 ) T( 1, 2 ) = -T( 2, 1 ) END IF WORK( M*M ) = ONE T( M, M ) = ONE * IF( N1.GT.1 ) THEN CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB, $ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ), $ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ), $ T( M, M-1 ) ) WORK( M*M ) = WORK( N2*M+N2+1 ) WORK( M*M-1 ) = -WORK( N2*M+N2+2 ) T( M, M ) = T( N2+1, N2+1 ) T( M-1, M ) = -T( M, M-1 ) END IF CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ), $ LDA, ZERO, WORK( M*M+1 ), N2 ) CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ), $ LDA ) CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ), $ LDB, ZERO, WORK( M*M+1 ), N2 ) CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ), $ LDB ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO, $ WORK( M*M+1 ), M ) CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST ) CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA, $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA ) CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB, $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB ) CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO, $ WORK, M ) CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST ) * * Accumulate transformations into Q and Z if requested. * IF( WANTQ ) THEN CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI, $ LDST, ZERO, WORK, N ) CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ ) * END IF * IF( WANTZ ) THEN CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR, $ LDST, ZERO, WORK, N ) CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ ) * END IF * * Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and * (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). * I = J1 + M IF( I.LE.N ) THEN CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, $ A( J1, I ), LDA, ZERO, WORK, M ) CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA ) CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, $ B( J1, I ), LDB, ZERO, WORK, M ) CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB ) END IF I = J1 - 1 IF( I.GT.0 ) THEN CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR, $ LDST, ZERO, WORK, I ) CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA ) CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR, $ LDST, ZERO, WORK, I ) CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB ) END IF * * Exit with INFO = 0 if swap was successfully performed. * RETURN * END IF * * Exit with INFO = 1 if swap was rejected. * 70 CONTINUE * INFO = 1 RETURN * * End of DTGEX2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtgexc.f000066400000000000000000000374551522610125300262460ustar00rootroot00000000000000*> \brief \b DTGEXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGEXC reorders the generalized real Schur decomposition of a real *> matrix pair (A,B) using an orthogonal equivalence transformation *> *> (A, B) = Q * (A, B) * Z**T, *> *> so that the diagonal block of (A, B) with row index IFST is moved *> to row ILST. *> *> (A, B) must be in generalized real Schur canonical form (as returned *> by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 *> diagonal blocks. B is upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T *> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 matrix A in generalized real Schur canonical *> form. *> On exit, the updated matrix A, again in generalized *> real Schur canonical form. *> \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 matrix B in generalized real Schur canonical *> form (A,B). *> On exit, the updated matrix B, again in generalized *> real Schur canonical form (A,B). *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. *> On exit, the updated matrix Q. *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., the orthogonal matrix Z. *> On exit, the updated matrix Z. *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in,out] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> Specify the reordering of the diagonal blocks of (A, B). *> The block with row index IFST is moved to row ILST, by a *> sequence of swapping between adjacent blocks. *> On exit, if IFST pointed on entry to the second row of *> a 2-by-2 block, it is changed to point to the first row; *> ILST always points to the first row of the block in its *> final position (which may differ from its input value by *> +1 or -1). 1 <= IFST, ILST <= 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 dimension of the array WORK. *> LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. *> *> 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. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. (A, B) may have been partially reordered, *> and ILST points to the first row of the current *> position of the block being moved. *> \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 Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, 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 .. LOGICAL WANTQ, WANTZ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER HERE, LWMIN, NBF, NBL, NBNEXT * .. * .. External Subroutines .. EXTERNAL DTGEX2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input arguments. * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -12 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LWMIN = 1 ELSE LWMIN = 4*N + 16 END IF WORK(1) = LWMIN * IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN INFO = -15 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGEXC', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of the specified block and find out * if it is 1-by-1 or 2-by-2. * IF( IFST.GT.1 ) THEN IF( A( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( A( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out if it is 1-by-1 or 2-by-2. * IF( ILST.GT.1 ) THEN IF( A( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( A( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST. * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap with next one below. * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1-by-1 or 2-by-2. * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2-by-2 block breaks into two 1-by-1 blocks. * IF( NBF.EQ.2 ) THEN IF( A( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1-by-1 blocks, each of which * must be swapped individually. * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( A( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 * ELSE * * Recompute NBNEXT in case of 2-by-2 split. * IF( A( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2-by-2 block did not split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2-by-2 block did split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 END IF * END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 ELSE HERE = IFST * 20 CONTINUE * * Swap with next one below. * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1-by-1 or 2-by-2. * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( A( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2-by-2 block breaks into two 1-by-1 blocks. * IF( NBF.EQ.2 ) THEN IF( A( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1-by-1 blocks, each of which * must be swapped individually. * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( A( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 ELSE * * Recompute NBNEXT in case of 2-by-2 split. * IF( A( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2-by-2 block did not split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2-by-2 block did split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE WORK( 1 ) = LWMIN RETURN * * End of DTGEXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtgsen.f000066400000000000000000000716131522610125300262460ustar00rootroot00000000000000*> \brief \b DTGSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ M, N * DOUBLE PRECISION PL, PR * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSEN reorders the generalized real Schur decomposition of a real *> matrix pair (A, B) (in terms of an orthonormal equivalence trans- *> formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues *> appears in the leading diagonal blocks of the upper quasi-triangular *> matrix A and the upper triangular B. The leading columns of Q and *> Z form orthonormal bases of the corresponding left and right eigen- *> spaces (deflating subspaces). (A, B) must be in generalized real *> Schur canonical form (as returned by DGGES), i.e. A is block upper *> triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper *> triangular. *> *> DTGSEN also computes the generalized eigenvalues *> *> w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) *> *> of the reordered matrix pair (A, B). *> *> Optionally, DTGSEN computes the estimates of reciprocal condition *> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), *> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) *> between the matrix pairs (A11, B11) and (A22,B22) that correspond to *> the selected cluster and the eigenvalues outside the cluster, resp., *> and norms of "projections" onto left and right eigenspaces w.r.t. *> the selected cluster in the (1,1)-block. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (PL and PR) or the deflating subspaces *> (Difu and Difl): *> =0: Only reorder w.r.t. SELECT. No extras. *> =1: Reciprocal of norms of "projections" onto left and right *> eigenspaces w.r.t. the selected cluster (PL and PR). *> =2: Upper bounds on Difu and Difl. F-norm-based estimate *> (DIF(1:2)). *> =3: Estimate of Difu and Difl. 1-norm-based estimate *> (DIF(1:2)). *> About 5 times as expensive as IJOB = 2. *> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic *> version to get it all. *> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) *> \endverbatim *> *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. *> To select a real eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. To select a complex conjugate pair of eigenvalues *> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, *> either SELECT(j) or SELECT(j+1) or both must be set to *> .TRUE.; a complex conjugate pair of eigenvalues must be *> either both included in the cluster or both excluded. *> \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 upper quasi-triangular matrix A, with (A, B) in *> generalized real Schur canonical form. *> On exit, A is overwritten by the reordered matrix A. *> \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 upper triangular matrix B, with (A, B) in *> generalized real Schur canonical form. *> On exit, B is overwritten by the reordered matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real generalized Schur form of (A,B) were further reduced *> to triangular form using complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. *> On exit, Q has been postmultiplied by the left orthogonal *> transformation matrix which reorder (A, B); The leading M *> columns of Q form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> and if WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. *> On exit, Z has been postmultiplied by the left orthogonal *> transformation matrix which reorder (A, B); The leading M *> columns of Z form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified pair of left and right eigen- *> spaces (deflating subspaces). 0 <= M <= N. *> \endverbatim *> *> \param[out] PL *> \verbatim *> PL is DOUBLE PRECISION *> \endverbatim *> \param[out] PR *> \verbatim *> PR is DOUBLE PRECISION *> *> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the *> reciprocal of the norm of "projections" onto left and right *> eigenspaces with respect to the selected cluster. *> 0 < PL, PR <= 1. *> If M = 0 or M = N, PL = PR = 1. *> If IJOB = 0, 2 or 3, PL and PR are not referenced. *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION array, dimension (2). *> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. *> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on *> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based *> estimates of Difu and Difl. *> If M = 0 or N, DIF(1:2) = F-norm([A, B]). *> If IJOB = 0 or 1, DIF is not referenced. *> \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. LWORK >= 4*N+16. *> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). *> If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-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] 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. LIWORK >= 1. *> If IJOB = 1, 2 or 4, LIWORK >= N+6. *> If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). *> *> 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. *> =1: Reordering of (A, B) failed because the transformed *> matrix pair (A, B) would be too far from generalized *> Schur form; the problem is very ill-conditioned. *> (A, B) may have been partially reordered. *> If requested, 0 is returned in DIF(*), PL and PR. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> DTGSEN first collects the selected eigenvalues by computing *> orthogonal U and W that move them to the top left corner of (A, B). *> In other words, the selected eigenvalues are the eigenvalues of *> (A11, B11) in: *> *> U**T*(A, B)*W = (A11 A12) (B11 B12) n1 *> ( 0 A22),( 0 B22) n2 *> n1 n2 n1 n2 *> *> where N = n1+n2 and U**T means the transpose of U. The first n1 columns *> of U and W span the specified pair of left and right eigenspaces *> (deflating subspaces) of (A, B). *> *> If (A, B) has been obtained from the generalized real Schur *> decomposition of a matrix pair (C, D) = Q*(A, B)*Z**T, then the *> reordered generalized real Schur form of (C, D) is given by *> *> (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T, *> *> and the first n1 columns of Q*U and Z*W span the corresponding *> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). *> *> Note that if the selected eigenvalue is sufficiently ill-conditioned, *> then its value may differ significantly from its value before *> reordering. *> *> The reciprocal condition numbers of the left and right eigenspaces *> spanned by the first n1 columns of U and W (or Q*U and Z*W) may *> be returned in DIF(1:2), corresponding to Difu and Difl, resp. *> *> The Difu and Difl are defined as: *> *> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) *> and *> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], *> *> where sigma-min(Zu) is the smallest singular value of the *> (2*n1*n2)-by-(2*n1*n2) matrix *> *> Zu = [ kron(In2, A11) -kron(A22**T, In1) ] *> [ kron(In2, B11) -kron(B22**T, In1) ]. *> *> Here, Inx is the identity matrix of size nx and A22**T is the *> transpose of A22. kron(X, Y) is the Kronecker product between *> the matrices X and Y. *> *> When DIF(2) is small, small changes in (A, B) can cause large changes *> in the deflating subspace. An approximate (asymptotic) bound on the *> maximum angular error in the computed deflating subspaces is *> *> EPS * norm((A, B)) / DIF(2), *> *> where EPS is the machine precision. *> *> The reciprocal norm of the projectors on the left and right *> eigenspaces associated with (A11, B11) may be returned in PL and PR. *> They are computed as follows. First we compute L and R so that *> P*(A, B)*Q is block diagonal, where *> *> P = ( I -L ) n1 Q = ( I R ) n1 *> ( 0 I ) n2 and ( 0 I ) n2 *> n1 n2 n1 n2 *> *> and (L, R) is the solution to the generalized Sylvester equation *> *> A11*R - L*A22 = -A12 *> B11*R - L*B22 = -B12 *> *> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). *> An approximate (asymptotic) bound on the average absolute error of *> the selected eigenvalues is *> *> EPS * norm((A, B)) / PL. *> *> There are also global error bounds which valid for perturbations up *> to a certain restriction: A lower bound (x) on the smallest *> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and *> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), *> (i.e. (A + E, B + F), is *> *> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). *> *> An approximate bound on x can be computed from DIF(1:2), PL and PR. *> *> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed *> (L', R') and unperturbed (L, R) left and right deflating subspaces *> associated with the selected cluster in the (1,1)-blocks can be *> bounded as *> *> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) *> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) *> *> See LAPACK User's Guide section 4.11 or the following references *> for more information. *> *> Note that if the default method for computing the Frobenius-norm- *> based estimate DIF is not wanted (see DLATDF), then the parameter *> IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF *> (IJOB = 2 will be used)). See DTGSYL for more details. *> \endverbatim * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> \endverbatim *> * ===================================================================== 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.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 .. LOGICAL WANTQ, WANTZ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, $ M, N DOUBLE PRECISION PL, PR * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IDIFJB PARAMETER ( IDIFJB = 3 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2, $ WANTP INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN, $ MN2, N1, N2 DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL, $ XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -14 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -16 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSEN', -INFO ) RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS IERR = 0 * WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 WANTD = WANTD1 .OR. WANTD2 * * Set M to the dimension of the specified pair of deflating * subspaces. * M = 0 PAIR = .FALSE. IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( A( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 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 ) ) LIWMIN = MAX( 1, N+6 ) ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) ) LIWMIN = MAX( 1, 2*M*( N-M ), N+6 ) ELSE LWMIN = MAX( 1, 4*N+16 ) LIWMIN = 1 END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -22 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -24 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTP ) THEN PL = ONE PR = ONE END IF IF( WANTD ) THEN DSCALE = ZERO DSUM = ONE DO 20 I = 1, N CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 20 CONTINUE DIF( 1 ) = DSCALE*SQRT( DSUM ) DIF( 2 ) = DIF( 1 ) END IF GO TO 60 END IF * * Collect the selected blocks at the top-left corner of (A, B). * KS = 0 PAIR = .FALSE. DO 30 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE * SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF * IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * Perform the reordering of diagonal blocks in (A, B) * by orthogonal transformation matrices and update * Q and Z accordingly (if requested): * KK = K IF( K.NE.KS ) $ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, KK, KS, WORK, LWORK, IERR ) * IF( IERR.GT.0 ) THEN * * Swap is rejected: exit. * INFO = 1 IF( WANTP ) THEN PL = ZERO PR = ZERO END IF IF( WANTD ) THEN DIF( 1 ) = ZERO DIF( 2 ) = ZERO END IF GO TO 60 END IF * IF( PAIR ) $ KS = KS + 1 END IF END IF 30 CONTINUE IF( WANTP ) THEN * * Solve generalized Sylvester equation for R and L * and compute PL and PR. * N1 = M N2 = N - M I = N1 + 1 IJB = 0 CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), $ N1 ) CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Estimate the reciprocal of norms of "projections" onto left * and right eigenspaces. * RDSCAL = ZERO DSUM = ONE CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) PL = RDSCAL*SQRT( DSUM ) IF( PL.EQ.ZERO ) THEN PL = ONE ELSE PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) END IF RDSCAL = ZERO DSUM = ONE CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) PR = RDSCAL*SQRT( DSUM ) IF( PR.EQ.ZERO ) THEN PR = ONE ELSE PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) END IF END IF * IF( WANTD ) THEN * * Compute estimates of Difu and Difl. * IF( WANTD1 ) THEN N1 = M N2 = N - M I = N1 + 1 IJB = IDIFJB * * Frobenius norm-based Difu-estimate. * CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), $ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Frobenius norm-based Difl-estimate. * CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), $ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) ELSE * * * Compute 1-norm-based estimates of Difu and Difl using * reversed communication with DLACN2. In each step a * generalized Sylvester equation or a transposed variant * is solved. * KASE = 0 N1 = M N2 = N - M I = N1 + 1 IJB = 0 MN2 = 2*N1*N2 * * 1-norm-based estimate of Difu. * 40 CONTINUE CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation. * CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 40 END IF DIF( 1 ) = DSCALE / DIF( 1 ) * * 1-norm-based estimate of Difl. * 50 CONTINUE CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation. * CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 50 END IF DIF( 2 ) = DSCALE / DIF( 2 ) * END IF END IF * 60 CONTINUE * * Compute generalized eigenvalues of reordered pair (A, B) and * normalize the generalized Schur form. * PAIR = .FALSE. DO 80 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE * IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. END IF END IF * IF( PAIR ) THEN * * Compute the eigenvalue(s) at position K. * WORK( 1 ) = A( K, K ) WORK( 2 ) = A( K+1, K ) WORK( 3 ) = A( K, K+1 ) WORK( 4 ) = A( K+1, K+1 ) WORK( 5 ) = B( K, K ) WORK( 6 ) = B( K+1, K ) WORK( 7 ) = B( K, K+1 ) WORK( 8 ) = B( K+1, K+1 ) CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ), $ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ), $ ALPHAI( K ) ) ALPHAI( K+1 ) = -ALPHAI( K ) * ELSE * IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN * * If B(K,K) is negative, make it positive * DO 70 I = 1, N A( K, I ) = -A( K, I ) B( K, I ) = -B( K, I ) IF( WANTQ ) Q( I, K ) = -Q( I, K ) 70 CONTINUE END IF * ALPHAR( K ) = A( K, K ) ALPHAI( K ) = ZERO BETA( K ) = B( K, K ) * END IF END IF 80 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DTGSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtgsy2.f000066400000000000000000001100371522610125300261700ustar00rootroot00000000000000*> \brief \b DTGSY2 solves the generalized Sylvester equation (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ PQ * DOUBLE PRECISION RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSY2 solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F, *> *> using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, *> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, *> N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) *> must be in generalized Schur canonical form, i.e. A, B are upper *> quasi triangular and D, E are upper triangular. The solution (R, L) *> overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor *> chosen to avoid overflow. *> *> In matrix notation solving equation (1) corresponds to solve *> Z*x = scale*b, where Z is defined as *> *> Z = [ kron(In, A) -kron(B**T, Im) ] (2) *> [ kron(In, D) -kron(E**T, Im) ], *> *> Ik is the identity matrix of size k and X**T is the transpose of X. *> kron(X, Y) is the Kronecker product between the matrices X and Y. *> In the process of solving (1), we solve a number of such systems *> where Dim(In), Dim(In) = 1 or 2. *> *> If TRANS = 'T', solve the transposed system Z**T*y = scale*b for y, *> which is equivalent to solve for R and L in *> *> A**T * R + D**T * L = scale * C (3) *> R * B**T + L * E**T = scale * -F *> *> This case is used to compute an estimate of Dif[(A, D), (B, E)] = *> sigma_min(Z) using reverse communicaton with DLACON. *> *> DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL *> of an upper bound on the separation between to matrix pairs. Then *> the input (A, D), (B, E) are sub-pencils of the matrix pair in *> DTGSYL. See DTGSYL for details. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T': solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> = 0: solve (1) only. *> = 1: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (look ahead strategy is used). *> = 2: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (DGECON on sub-systems is used.) *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the order of A and D, and the row *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of B and E, and the column *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, M) *> On entry, A contains an upper quasi triangular matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the matrix A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, B contains an upper quasi triangular matrix. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1). *> On exit, if IJOB = 0, C has been overwritten by the *> solution R. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the matrix C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (LDD, M) *> On entry, D contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the matrix D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (LDE, N) *> On entry, E contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the matrix E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1). *> On exit, if IJOB = 0, F has been overwritten by the *> solution L. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the matrix F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions *> R and L (C and F on entry) will hold the solutions to a *> slightly perturbed system but the input matrices A, B, D and *> E have not been changed. If SCALE = 0, R and L will hold the *> solutions to the homogeneous system with C = F = 0. Normally, *> SCALE = 1. *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is DOUBLE PRECISION *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by DTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is DOUBLE PRECISION *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when DTGSY2 is called by *> DTGSYL. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+N+2) *> \endverbatim *> *> \param[out] PQ *> \verbatim *> PQ is INTEGER *> On exit, the number of subsystems (of size 2-by-2, 4-by-4 and *> 8-by-8) solved by this routine. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, if INFO is set to *> =0: Successful exit *> <0: If INFO = -i, the i-th argument had an illegal value. *> >0: The matrix pairs (A, D) and (B, E) have common or very *> close eigenvalues. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, $ PQ DOUBLE PRECISION RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * ===================================================================== * Replaced various illegal calls to DCOPY by calls to DLASET. * Sven Hammarling, 27/5/02. * * .. Parameters .. INTEGER LDZ PARAMETER ( LDZ = 8 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, $ K, MB, NB, P, Q, ZDIM DOUBLE PRECISION ALPHA, SCALOC * .. * .. Local Arrays .. INTEGER IPIV( LDZ ), JPIV( LDZ ) DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 IERR = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSY2', -INFO ) RETURN END IF * * Determine block structure of A * PQ = 0 P = 0 I = 1 10 CONTINUE IF( I.GT.M ) $ GO TO 20 P = P + 1 IWORK( P ) = I IF( I.EQ.M ) $ GO TO 20 IF( A( I+1, I ).NE.ZERO ) THEN I = I + 2 ELSE I = I + 1 END IF GO TO 10 20 CONTINUE IWORK( P+1 ) = M + 1 * * Determine block structure of B * Q = P + 1 J = 1 30 CONTINUE IF( J.GT.N ) $ GO TO 40 Q = Q + 1 IWORK( Q ) = J IF( J.EQ.N ) $ GO TO 40 IF( B( J+1, J ).NE.ZERO ) THEN J = J + 2 ELSE J = J + 1 END IF GO TO 30 40 CONTINUE IWORK( Q+1 ) = N + 1 PQ = P*( Q-P-1 ) * IF( NOTRAN ) THEN * * Solve (I, J) - subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1, ..., 1; J = 1, 2, ..., Q * SCALE = ONE SCALOC = ONE DO 120 J = P + 2, Q JS = IWORK( J ) JSP1 = JS + 1 JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 110 I = P, 1, -1 * IS = IWORK( I ) ISP1 = IS + 1 IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 ZDIM = MB*NB*2 * IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 2-by-2 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = D( IS, IS ) Z( 1, 2 ) = -B( JS, JS ) Z( 2, 2 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = F( IS, JS ) * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 50 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 50 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) F( IS, JS ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN ALPHA = -RHS( 1 ) CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), $ 1 ) CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), $ 1 ) END IF IF( J.LT.Q ) THEN CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN * * Build a 4-by-4 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = ZERO Z( 3, 1 ) = D( IS, IS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = ZERO Z( 2, 2 ) = A( IS, IS ) Z( 3, 2 ) = ZERO Z( 4, 2 ) = D( IS, IS ) * Z( 1, 3 ) = -B( JS, JS ) Z( 2, 3 ) = -B( JS, JSP1 ) Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = -E( JS, JSP1 ) * Z( 1, 4 ) = -B( JSP1, JS ) Z( 2, 4 ) = -B( JSP1, JSP1 ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( IS, JSP1 ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( IS, JSP1 ) * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 60 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 60 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( IS, JSP1 ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( IS, JSP1 ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), $ 1, C( 1, JS ), LDC ) CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), $ 1, F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 4-by-4 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( ISP1, IS ) Z( 3, 1 ) = D( IS, IS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = A( IS, ISP1 ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 3, 2 ) = D( IS, ISP1 ) Z( 4, 2 ) = D( ISP1, ISP1 ) * Z( 1, 3 ) = -B( JS, JS ) Z( 2, 3 ) = ZERO Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = -B( JS, JS ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( ISP1, JS ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( ISP1, JS ) * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 70 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( ISP1, JS ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( ISP1, JS ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) END IF IF( J.LT.Q ) THEN CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN * * Build an 8-by-8 system Z * x = RHS * CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( ISP1, IS ) Z( 5, 1 ) = D( IS, IS ) * Z( 1, 2 ) = A( IS, ISP1 ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 5, 2 ) = D( IS, ISP1 ) Z( 6, 2 ) = D( ISP1, ISP1 ) * Z( 3, 3 ) = A( IS, IS ) Z( 4, 3 ) = A( ISP1, IS ) Z( 7, 3 ) = D( IS, IS ) * Z( 3, 4 ) = A( IS, ISP1 ) Z( 4, 4 ) = A( ISP1, ISP1 ) Z( 7, 4 ) = D( IS, ISP1 ) Z( 8, 4 ) = D( ISP1, ISP1 ) * Z( 1, 5 ) = -B( JS, JS ) Z( 3, 5 ) = -B( JS, JSP1 ) Z( 5, 5 ) = -E( JS, JS ) Z( 7, 5 ) = -E( JS, JSP1 ) * Z( 2, 6 ) = -B( JS, JS ) Z( 4, 6 ) = -B( JS, JSP1 ) Z( 6, 6 ) = -E( JS, JS ) Z( 8, 6 ) = -E( JS, JSP1 ) * Z( 1, 7 ) = -B( JSP1, JS ) Z( 3, 7 ) = -B( JSP1, JSP1 ) Z( 7, 7 ) = -E( JSP1, JSP1 ) * Z( 2, 8 ) = -B( JSP1, JS ) Z( 4, 8 ) = -B( JSP1, JSP1 ) Z( 8, 8 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * K = 1 II = MB*NB + 1 DO 80 JJ = 0, NB - 1 CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) K = K + MB II = II + MB 80 CONTINUE * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 90 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * K = 1 II = MB*NB + 1 DO 100 JJ = 0, NB - 1 CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) K = K + MB II = II + MB 100 CONTINUE * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, $ C( 1, JS ), LDC ) CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN K = MB*NB + 1 CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), $ MB, B( JS, JE+1 ), LDB, ONE, $ C( IS, JE+1 ), LDC ) CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), $ MB, E( JS, JE+1 ), LDE, ONE, $ F( IS, JE+1 ), LDF ) END IF * END IF * 110 CONTINUE 120 CONTINUE ELSE * * Solve (I, J) - subsystem * A(I, I)**T * R(I, J) + D(I, I)**T * L(J, J) = C(I, J) * R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 * SCALE = ONE SCALOC = ONE DO 200 I = 1, P * IS = IWORK( I ) ISP1 = IS + 1 IE = IWORK ( I+1 ) - 1 MB = IE - IS + 1 DO 190 J = Q, P + 2, -1 * JS = IWORK( J ) JSP1 = JS + 1 JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 ZDIM = MB*NB*2 IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 2-by-2 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = -B( JS, JS ) Z( 1, 2 ) = D( IS, IS ) Z( 2, 2 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = F( IS, JS ) * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 130 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 130 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) F( IS, JS ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN ALPHA = RHS( 1 ) CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), $ LDF ) ALPHA = RHS( 2 ) CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), $ LDF ) END IF IF( I.LT.P ) THEN ALPHA = -RHS( 1 ) CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, $ C( IE+1, JS ), 1 ) ALPHA = -RHS( 2 ) CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, $ C( IE+1, JS ), 1 ) END IF * ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN * * Build a 4-by-4 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = ZERO Z( 3, 1 ) = -B( JS, JS ) Z( 4, 1 ) = -B( JSP1, JS ) * Z( 1, 2 ) = ZERO Z( 2, 2 ) = A( IS, IS ) Z( 3, 2 ) = -B( JS, JSP1 ) Z( 4, 2 ) = -B( JSP1, JSP1 ) * Z( 1, 3 ) = D( IS, IS ) Z( 2, 3 ) = ZERO Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = D( IS, IS ) Z( 3, 4 ) = -E( JS, JSP1 ) Z( 4, 4 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( IS, JSP1 ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( IS, JSP1 ) * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 140 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( IS, JSP1 ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( IS, JSP1 ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, $ F( IS, 1 ), LDF ) CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, $ F( IS, 1 ), LDF ) CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, $ F( IS, 1 ), LDF ) CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 4-by-4 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( IS, ISP1 ) Z( 3, 1 ) = -B( JS, JS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = A( ISP1, IS ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 3, 2 ) = ZERO Z( 4, 2 ) = -B( JS, JS ) * Z( 1, 3 ) = D( IS, IS ) Z( 2, 3 ) = D( IS, ISP1 ) Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = D( ISP1, ISP1 ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( ISP1, JS ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( ISP1, JS ) * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 150 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( ISP1, JS ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( ISP1, JS ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), $ 1, F( IS, 1 ), LDF ) CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), $ 1, F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), $ 1 ) CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), $ 1 ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN * * Build an 8-by-8 system Z**T * x = RHS * CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( IS, ISP1 ) Z( 5, 1 ) = -B( JS, JS ) Z( 7, 1 ) = -B( JSP1, JS ) * Z( 1, 2 ) = A( ISP1, IS ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 6, 2 ) = -B( JS, JS ) Z( 8, 2 ) = -B( JSP1, JS ) * Z( 3, 3 ) = A( IS, IS ) Z( 4, 3 ) = A( IS, ISP1 ) Z( 5, 3 ) = -B( JS, JSP1 ) Z( 7, 3 ) = -B( JSP1, JSP1 ) * Z( 3, 4 ) = A( ISP1, IS ) Z( 4, 4 ) = A( ISP1, ISP1 ) Z( 6, 4 ) = -B( JS, JSP1 ) Z( 8, 4 ) = -B( JSP1, JSP1 ) * Z( 1, 5 ) = D( IS, IS ) Z( 2, 5 ) = D( IS, ISP1 ) Z( 5, 5 ) = -E( JS, JS ) * Z( 2, 6 ) = D( ISP1, ISP1 ) Z( 6, 6 ) = -E( JS, JS ) * Z( 3, 7 ) = D( IS, IS ) Z( 4, 7 ) = D( IS, ISP1 ) Z( 5, 7 ) = -E( JS, JSP1 ) Z( 7, 7 ) = -E( JSP1, JSP1 ) * Z( 4, 8 ) = D( ISP1, ISP1 ) Z( 6, 8 ) = -E( JS, JSP1 ) Z( 8, 8 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * K = 1 II = MB*NB + 1 DO 160 JJ = 0, NB - 1 CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) K = K + MB II = II + MB 160 CONTINUE * * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 170 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 170 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * K = 1 II = MB*NB + 1 DO 180 JJ = 0, NB - 1 CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) K = K + MB II = II + MB 180 CONTINUE * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, $ F( IS, 1 ), LDF ) CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, $ ONE, C( IE+1, JS ), LDC ) CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, $ ONE, C( IE+1, JS ), LDC ) END IF * END IF * 190 CONTINUE 200 CONTINUE * END IF RETURN * * End of DTGSY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtgsyl.f000066400000000000000000000542751522610125300262750ustar00rootroot00000000000000*> \brief \b DTGSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ LWORK, M, N * DOUBLE PRECISION DIF, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSYL solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> where R and L are unknown m-by-n matrices, (A, D), (B, E) and *> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, *> respectively, with real entries. (A, D) and (B, E) must be in *> generalized (real) Schur canonical form, i.e. A, B are upper quasi *> triangular and D, E are upper triangular. *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output *> scaling factor chosen to avoid overflow. *> *> In matrix notation (1) is equivalent to solve Zx = scale b, where *> Z is defined as *> *> Z = [ kron(In, A) -kron(B**T, Im) ] (2) *> [ kron(In, D) -kron(E**T, Im) ]. *> *> Here Ik is the identity matrix of size k and X**T is the transpose of *> X. kron(X, Y) is the Kronecker product between the matrices X and Y. *> *> If TRANS = 'T', DTGSYL solves the transposed system Z**T*y = scale*b, *> which is equivalent to solve for R and L in *> *> A**T * R + D**T * L = scale * C (3) *> R * B**T + L * E**T = scale * -F *> *> This case (TRANS = 'T') is used to compute an one-norm-based estimate *> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) *> and (B,E), using DLACON. *> *> If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate *> of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the *> reciprocal of the smallest singular value of Z. See [1-2] for more *> information. *> *> This is a level 3 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T', solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: The functionality of 0 and 3. *> =2: The functionality of 0 and 4. *> =3: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (look ahead strategy IJOB = 1 is used). *> =4: Only an estimate of Dif[(A,D), (B,E)] is computed. *> ( DGECON on sub-systems is used ). *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrices A and D, and the row dimension of *> the matrices C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices B and E, and the column dimension *> of the matrices C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, M) *> The upper quasi triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> The upper quasi triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, C has been overwritten by *> the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (LDD, M) *> The upper triangular matrix D. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the array D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (LDE, N) *> The upper triangular matrix E. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the array E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, F has been overwritten by *> the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION *> On exit DIF is the reciprocal of a lower bound of the *> reciprocal of the Dif-function, i.e. DIF is an upper bound of *> Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). *> IF IJOB = 0 or TRANS = 'T', DIF is not touched. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit SCALE is the scaling factor in (1) or (3). *> If 0 < SCALE < 1, C and F hold the solutions R and L, resp., *> to a slightly perturbed system but the input matrices A, B, D *> and E have not been changed. If SCALE = 0, C and F hold the *> solutions R and L, respectively, to the homogeneous system *> with C = F = 0. Normally, SCALE = 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. LWORK > = 1. *> If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*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] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+N+6) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: successful exit *> <0: If INFO = -i, the i-th argument had an illegal value. *> >0: (A, D) and (B, E) have common or close eigenvalues. *> \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: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, *> No 1, 1996. *> *> [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester *> Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. *> Appl., 15(4):1045-1060, 1994 *> *> [3] B. Kagstrom and L. Westin, Generalized Schur Methods with *> Condition Estimators for Solving the Generalized Sylvester *> Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, *> July 1989, pp 745-751. *> \endverbatim *> * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, $ LWORK, M, N DOUBLE PRECISION DIF, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ), $ WORK( * ) * .. * * ===================================================================== * Replaced various illegal calls to DCOPY by calls to DLASET. * Sven Hammarling, 1/5/02. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, NOTRAN INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, $ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DTGSY2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF * IF( INFO.EQ.0 ) THEN IF( NOTRAN ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN LWMIN = MAX( 1, 2*M*N ) ELSE LWMIN = 1 END IF ELSE LWMIN = 1 END IF WORK( 1 ) = LWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSYL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN SCALE = 1 IF( NOTRAN ) THEN IF( IJOB.NE.0 ) THEN DIF = 0 END IF END IF RETURN END IF * * Determine optimal block sizes MB and NB * MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 ) NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 ) * ISOLVE = 1 IFUNC = 0 IF( NOTRAN ) THEN IF( IJOB.GE.3 ) THEN IFUNC = IJOB - 2 CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( IJOB.GE.1 ) THEN ISOLVE = 2 END IF END IF * IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) $ THEN * DO 30 IROUND = 1, ISOLVE * * Use unblocked Level 2 solver * DSCALE = ZERO DSUM = ONE PQ = 0 CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, $ IWORK, PQ, INFO ) IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF * IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL DLACPY( 'F', M, N, C, LDC, WORK, M ) CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL DLACPY( 'F', M, N, WORK, M, C, LDC ) CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 30 CONTINUE * RETURN END IF * * Determine block structure of A * P = 0 I = 1 40 CONTINUE IF( I.GT.M ) $ GO TO 50 P = P + 1 IWORK( P ) = I I = I + MB IF( I.GE.M ) $ GO TO 50 IF( A( I, I-1 ).NE.ZERO ) $ I = I + 1 GO TO 40 50 CONTINUE * IWORK( P+1 ) = M + 1 IF( IWORK( P ).EQ.IWORK( P+1 ) ) $ P = P - 1 * * Determine block structure of B * Q = P + 1 J = 1 60 CONTINUE IF( J.GT.N ) $ GO TO 70 Q = Q + 1 IWORK( Q ) = J J = J + NB IF( J.GE.N ) $ GO TO 70 IF( B( J, J-1 ).NE.ZERO ) $ J = J + 1 GO TO 60 70 CONTINUE * IWORK( Q+1 ) = N + 1 IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) $ Q = Q - 1 * IF( NOTRAN ) THEN * DO 150 IROUND = 1, ISOLVE * * Solve (I, J)-subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1,..., 1; J = 1, 2,..., Q * DSCALE = ZERO DSUM = ONE PQ = 0 SCALE = ONE DO 130 J = P + 2, Q JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 120 I = P, 1, -1 IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 PPQQ = 0 CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ IWORK( Q+2 ), PPQQ, LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO * PQ = PQ + PPQQ IF( SCALOC.NE.ONE ) THEN DO 80 K = 1, JS - 1 CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 80 CONTINUE DO 90 K = JS, JE CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 ) CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 ) 90 CONTINUE DO 100 K = JS, JE CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) 100 CONTINUE DO 110 K = JE + 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE, $ C( 1, JS ), LDC ) CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE, $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, $ F( IS, JS ), LDF, B( JS, JE+1 ), LDB, $ ONE, C( IS, JE+1 ), LDC ) CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, $ F( IS, JS ), LDF, E( JS, JE+1 ), LDE, $ ONE, F( IS, JE+1 ), LDF ) END IF 120 CONTINUE 130 CONTINUE IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL DLACPY( 'F', M, N, C, LDC, WORK, M ) CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL DLACPY( 'F', M, N, WORK, M, C, LDC ) CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 150 CONTINUE * ELSE * * Solve transposed (I, J)-subsystem * A(I, I)**T * R(I, J) + D(I, I)**T * L(I, J) = C(I, J) * R(I, J) * B(J, J)**T + L(I, J) * E(J, J)**T = -F(I, J) * for I = 1,2,..., P; J = Q, Q-1,..., 1 * SCALE = ONE DO 210 I = 1, P IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 DO 200 J = Q, P + 2, -1 JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ IWORK( Q+2 ), PPQQ, LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO IF( SCALOC.NE.ONE ) THEN DO 160 K = 1, JS - 1 CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 160 CONTINUE DO 170 K = JS, JE CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 ) CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 ) 170 CONTINUE DO 180 K = JS, JE CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) 180 CONTINUE DO 190 K = JE + 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I, J) and L(I, J) into remaining equation. * IF( J.GT.P+2 ) THEN CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ), $ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ), $ LDF ) CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ), $ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ), $ LDF ) END IF IF( I.LT.P ) THEN CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE, $ C( IE+1, JS ), LDC ) CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE, $ C( IE+1, JS ), LDC ) END IF 200 CONTINUE 210 CONTINUE * END IF * WORK( 1 ) = LWMIN * RETURN * * End of DTGSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtplqt.f000066400000000000000000000175121522610125300262700ustar00rootroot00000000000000*> \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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 lower trapezoidal. *> *> The lower trapezoidal matrix B2 consists of the first L columns of a *> M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> [ W ] = [ I ] [ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtplqt2.f000066400000000000000000000213561522610125300263530ustar00rootroot00000000000000*> \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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ I ][ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtpmlqt.f000066400000000000000000000243031522610125300264410ustar00rootroot00000000000000*> \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 November 2017 * *> \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.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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, DTPRFB * .. * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtpmqrt.f000066400000000000000000000244241522610125300264530ustar00rootroot00000000000000*> \brief \b DTPMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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, * ), * $ 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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CTPQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CTPQRT 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 CTPQRT, stored as a NB-by-K matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \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*NB if SIDE = 'L', or M*NB 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 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 = '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. *> *> 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 DTPMQRT( SIDE, TRANS, M, N, K, L, NB, 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, NB, LDT * .. * .. Array Arguments .. DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), $ T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. 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 LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN LDVQ = MAX( 1, N ) 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( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) 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( 'DTPMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * DO I = 1, K, NB 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 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 IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB 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 CALL DTPRFB( 'L', 'N', '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. TRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 ELSE 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * END IF * RETURN * * End of DTPMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtpqrt.f000066400000000000000000000173211522610125300262740ustar00rootroot00000000000000*> \brief \b DTPQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 *> WY representation for Q. *> \endverbatim * * Arguments: * ========== * *> \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, and the order of the *> triangular matrix A. *> N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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 *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (NB*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 doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 number of blocks is B = ceiling(N/NB), where each *> 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 *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. *> \endverbatim *> * ===================================================================== SUBROUTINE DTPQRT( M, N, L, NB, 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, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, LB, MB, IINFO * .. * .. External Subroutines .. EXTERNAL DTPQRT2, 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( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPQRT', -INFO ) RETURN END IF * * Quick return if possible * 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 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF * 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, $ WORK, IB ) END IF END DO RETURN * * End of DTPQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtpqrt2.f000066400000000000000000000207611522610125300263600ustar00rootroot00000000000000*> \brief \b DTPQRT2 computes a QR 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 DTPQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \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, *> 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 upper 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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,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 doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**T *> *> where W^H is the conjugate transpose of W and T is the upper triangular *> factor of the block reflector. *> \endverbatim *> * ===================================================================== SUBROUTINE DTPQRT2( 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, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPQRT2', -INFO ) RETURN END IF * * 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) * P = M-L+MIN( L, I ) CALL DLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) ) IF( I.LT.N ) THEN * * W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)] * 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, $ 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 )) 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, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO * DO I = 2, N * * T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I)) * ALPHA = -T( I, 1 ) DO J = 1, I-1 T( J, I ) = ZERO END DO P = MIN( I-1, L ) MP = MIN( M-L+1, M ) NP = MIN( P+1, N ) * * Triangular part of B2 * DO J = 1, P T( J, I ) = ALPHA*B( M-L+J, I ) END DO CALL DTRMV( 'U', 'T', 'N', P, B( MP, 1 ), LDB, $ T( 1, I ), 1 ) * * Rectangular part of B2 * 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 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO * * End of DTPQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtprfb.f000066400000000000000000000626261522610125300262470ustar00rootroot00000000000000*> \brief \b DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPRFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * ), * $ 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 *> blocks A and B, either from the left or right. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**T from the Left *> = 'R': apply H or H**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'T': apply H**T (Transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columns *> = 'R': Rows *> \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 order of the matrix T, i.e. the number of elementary *> 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. *> K >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The pentagonal matrix V, which contains the elementary reflectors *> H(1), H(2), ..., H(K). See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= K. *> \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 *> 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. *> 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 *> H*C or H**T*C or C*H or C*H**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, dimension *> (LDWORK,N) if SIDE = 'L', *> (LDWORK,K) if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> 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. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \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, *> 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] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] *> [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 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. *> *> If DIRECT = 'F' and STOREV = 'C': V = [V1] *> [V2] *> - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) *> *> If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] *> *> - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'C': V = [V2] *> [V1] *> - 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. *> *> If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. *> *> If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. *> *> If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. *> \endverbatim *> * ===================================================================== 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.7.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 DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * * ========================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0, ZERO = 0.0 ) * .. * .. Local Scalars .. INTEGER I, J, MP, NP, KP LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 .OR. L.LT.0 ) RETURN * IF( LSAME( STOREV, 'C' ) ) THEN COLUMN = .TRUE. ROW = .FALSE. ELSE IF ( LSAME( STOREV, 'R' ) ) THEN COLUMN = .FALSE. ROW = .TRUE. ELSE COLUMN = .FALSE. ROW = .FALSE. END IF * IF( LSAME( SIDE, 'L' ) ) THEN LEFT = .TRUE. RIGHT = .FALSE. ELSE IF( LSAME( SIDE, 'R' ) ) THEN LEFT = .FALSE. RIGHT = .TRUE. ELSE LEFT = .FALSE. RIGHT = .FALSE. END IF * IF( LSAME( DIRECT, 'F' ) ) THEN FORWARD = .TRUE. BACKWARD = .FALSE. ELSE IF( LSAME( DIRECT, 'B' ) ) THEN FORWARD = .FALSE. BACKWARD = .TRUE. ELSE FORWARD = .FALSE. BACKWARD = .FALSE. END IF * * --------------------------------------------------------------------------- * IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (M-by-K) * * Form H C or H**T C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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, $ ONE, WORK, LDWORK ) 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, $ 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, 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 ) CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (N-by-K) * * Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - (A + B V) T or A = A - (A + B V) T**T * B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V, LDV, ONE, WORK, LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DGEMM( 'N', 'T', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, $ V( NP, KP ), LDV, ONE, B( 1, NP ), LDB ) CALL DTRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (M-by-K) * [ I ] (K-by-K) * * Form H C or H**T C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO * 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, $ 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 ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * 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, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL DTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (N-by-K) * [ I ] (K-by-K) * * Form C H or C H**T where C = [ B A ] (B is M-by-N, A is M-by-K) * * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - (A + B V) T or A = A - (A + B V) T**T * B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, $ V( NP, 1 ), LDV, ONE, B( 1, NP ), LDB ) CALL DGEMM( 'N', 'T', M, L, K-L, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DTRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**T C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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', '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, $ ONE, WORK, LDWORK ) CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), 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, $ 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( '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, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - (A + B V**T) T or A = A - (A + B V**T) T**T * B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL DTRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, NP ), LDV, $ 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, $ V( KP, 1 ), 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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 ) CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**T C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V( KP, MP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V, LDV, B, LDB, $ ZERO, WORK, 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', '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( '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, $ WORK, LDWORK, ONE, B, LDB ) CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**T where C = [ B A ] (A is M-by-K, B is M-by-N) * * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - (A + B V**T) T or A = A - (A + B V**T) T**T * B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL DTRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) 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 ) * 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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, $ V, LDV, ONE, B, LDB ) CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * END IF * RETURN * * End of DTPRFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtrevc.f000066400000000000000000001077441522610125300262560ustar00rootroot00000000000000*> \brief \b DTREVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTREVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTREVC 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. *> \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 (3*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 November 2017 * *> \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 DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, 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 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. DOUBLE PRECISION X( 2, 2 ) * .. * .. 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 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 * * 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( 'DTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * 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) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 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+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the 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+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+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+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+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+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+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( KI.GT.1 ) $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+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 ) 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+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*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+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+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 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+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+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL DCOPY( KI, WORK( 1+N2 ), 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( KI.GT.2 ) THEN CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL DSCAL( N, WORK( KI+N2 ), 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 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 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+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the 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+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+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+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+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+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+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+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+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( KI.LT.N ) $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+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 ) * 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+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (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+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 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+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+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), 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+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 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+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+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = 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 CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 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( KI.LT.N-1 ) THEN CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL DSCAL( N, WORK( KI+1+N2 ), 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 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of DTREVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtrexc.f000066400000000000000000000301121522610125300262400ustar00rootroot00000000000000*> \brief \b DTREXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTREXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTREXC reorders the real Schur factorization of a real matrix *> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is *> moved to row ILST. *> *> The real Schur form T is reordered by an orthogonal similarity *> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors *> is updated by postmultiplying it with Z. *> *> T must be in Schur canonical form (as returned by DHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] N *> \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 *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> Schur canonical form. *> On exit, the reordered upper quasi-triangular matrix, again *> 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] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> orthogonal transformation matrix Z which reorders T. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1, and if *> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> *> Specify the reordering of the diagonal blocks of T. *> The block with row index IFST is moved to row ILST, by a *> sequence of transpositions between adjacent blocks. *> On exit, if IFST pointed on entry to the second row of a *> 2-by-2 block, it is changed to point to the first row; ILST *> always points to the first row of the block in its final *> position (which may differ from its input value by +1 or -1). *> 1 <= IFST <= N; 1 <= ILST <= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION 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 *> = 1: two adjacent blocks were too close to swap (the problem *> is very ill-conditioned); T may have been partially *> reordered, and ILST points to the first row of the *> current position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, 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 COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL WANTQ INTEGER HERE, NBF, NBL, NBNEXT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAEXC, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test the input arguments. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN 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 ).AND.( N.GT.0 )) THEN INFO = -7 ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of specified block * and find out it is 1 by 1 or 2 by 2. * IF( IFST.GT.1 ) THEN IF( T( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( T( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out it is 1 by 1 or 2 by 2. * IF( ILST.GT.1 ) THEN IF( T( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( T( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF * IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap block with next one below * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( T( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, $ WORK, INFO ) HERE = HERE + 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, $ NBNEXT, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2 by 2 Block did split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, $ WORK, INFO ) HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 * ELSE * HERE = IFST 20 CONTINUE * * Swap block with next one above * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ NBF, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ 1, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, $ WORK, INFO ) HERE = HERE - 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2 by 2 Block did split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, $ WORK, INFO ) HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE * RETURN * * End of DTREXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtrsen.f000066400000000000000000000436011522610125300262550ustar00rootroot00000000000000*> \brief \b DTRSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRSEN reorders the real Schur factorization of a real matrix *> A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in *> the leading diagonal blocks of the upper quasi-triangular matrix T, *> and the leading columns of Q form an orthonormal basis of the *> corresponding right invariant subspace. *> *> Optionally the routine computes the reciprocal condition numbers of *> the cluster of eigenvalues and/or the invariant subspace. *> *> T must be in Schur canonical form (as returned by DHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (S) or the invariant subspace (SEP): *> = 'N': none; *> = 'E': for eigenvalues only (S); *> = 'V': for invariant subspace only (SEP); *> = 'B': for both eigenvalues and invariant subspace (S and *> SEP). *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select a real eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. To select a complex conjugate pair of eigenvalues *> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, *> either SELECT(j) or SELECT(j+1) or both must be set to *> .TRUE.; a complex conjugate pair of eigenvalues must be *> either both included in the cluster or both excluded. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> canonical form. *> On exit, T is overwritten by the reordered matrix T, again in *> Schur canonical form, with the selected eigenvalues in the *> leading diagonal blocks. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> orthogonal transformation matrix which reorders T; the *> leading M columns of Q form an orthonormal basis for the *> specified invariant subspace. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> *> The real and imaginary parts, respectively, of the reordered *> eigenvalues of T. The eigenvalues are stored in the same *> order as on the diagonal of T, with WR(i) = T(i,i) and, if *> T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and *> WI(i+1) = -WI(i). Note that if a complex eigenvalue is *> sufficiently ill-conditioned, then its value may differ *> significantly from its value before reordering. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified invariant subspace. *> 0 < = M <= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION *> If JOB = 'E' or 'B', S is a lower bound on the reciprocal *> condition number for the selected cluster of eigenvalues. *> S cannot underestimate the true reciprocal condition number *> by more than a factor of sqrt(N). If M = 0 or N, S = 1. *> If JOB = 'N' or 'V', S is not referenced. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is DOUBLE PRECISION *> If JOB = 'V' or 'B', SEP is the estimated reciprocal *> condition number of the specified invariant subspace. If *> M = 0 or N, SEP = norm(T). *> If JOB = 'N' or 'E', SEP is not referenced. *> \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 JOB = 'N', LWORK >= max(1,N); *> if JOB = 'E', LWORK >= max(1,M*(N-M)); *> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-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] 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 JOB = 'N' or 'E', LIWORK >= 1; *> if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). *> *> 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 *> = 1: reordering of T failed because some eigenvalues are too *> close to separate (the problem is very ill-conditioned); *> T may have been partially reordered, and WR and WI *> contain the eigenvalues in the same order as in T; S and *> SEP (if requested) are set to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> DTRSEN first collects the selected eigenvalues by computing an *> orthogonal transformation Z to move them to the top left corner of T. *> In other words, the selected eigenvalues are the eigenvalues of T11 *> in: *> *> Z**T * T * Z = ( T11 T12 ) n1 *> ( 0 T22 ) n2 *> n1 n2 *> *> where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns *> of Z span the specified invariant subspace of T. *> *> If T has been obtained from the real Schur factorization of a matrix *> A = Q*T*Q**T, then the reordered real Schur factorization of A is given *> by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span *> the corresponding invariant subspace of A. *> *> The reciprocal condition number of the average of the eigenvalues of *> T11 may be returned in S. S lies between 0 (very badly conditioned) *> and 1 (very well conditioned). It is computed as follows. First we *> compute R so that *> *> P = ( I R ) n1 *> ( 0 0 ) n2 *> n1 n2 *> *> is the projector on the invariant subspace associated with T11. *> R is the solution of the Sylvester equation: *> *> T11*R - R*T22 = T12. *> *> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote *> the two-norm of M. Then S is computed as the lower bound *> *> (1 + F-norm(R)**2)**(-1/2) *> *> on the reciprocal of 2-norm(P), the true reciprocal condition number. *> S cannot underestimate 1 / 2-norm(P) by more than a factor of *> sqrt(N). *> *> An approximate error bound for the computed average of the *> eigenvalues of T11 is *> *> EPS * norm(T) / S *> *> where EPS is the machine precision. *> *> The reciprocal condition number of the right invariant subspace *> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. *> SEP is defined as the separation of T11 and T22: *> *> sep( T11, T22 ) = sigma-min( C ) *> *> where sigma-min(C) is the smallest singular value of the *> n1*n2-by-n1*n2 matrix *> *> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) *> *> I(m) is an m by m identity matrix, and kprod denotes the Kronecker *> product. We estimate sigma-min(C) by the reciprocal of an estimate of *> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) *> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). *> *> When SEP is small, small changes in T can cause large changes in *> the invariant subspace. An approximate bound on the maximum angular *> error in the computed right invariant subspace is *> *> EPS * norm(T) / SEP *> \endverbatim *> * ===================================================================== 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.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 COMPQ, JOB INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), $ WR( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS, $ WANTSP INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, $ NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL LSAME, DLANGE * .. * .. External Subroutines .. EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE * * Set M to the dimension of the specified invariant subspace, * and test LWORK and LIWORK. * M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( T( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * IF( WANTSP ) THEN LWMIN = MAX( 1, 2*NN ) LIWMIN = MAX( 1, NN ) ELSE IF( LSAME( JOB, 'N' ) ) THEN LWMIN = MAX( 1, N ) LIWMIN = 1 ELSE IF( LSAME( JOB, 'E' ) ) THEN LWMIN = MAX( 1, NN ) LIWMIN = 1 END IF * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -15 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -17 END IF END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = DLANGE( '1', N, N, T, LDT, WORK ) GO TO 40 END IF * * Collect the selected blocks at the top-left corner of T. * KS = 0 PAIR = .FALSE. DO 20 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( T( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * IERR = 0 KK = K IF( K.NE.KS ) $ CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, $ IERR ) IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN * * Blocks too close to swap: exit. * INFO = 1 IF( WANTS ) $ S = ZERO IF( WANTSP ) $ SEP = ZERO GO TO 40 END IF IF( PAIR ) $ KS = KS + 1 END IF END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11**T*R - R*T22**T = scale*X. * CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Store the output eigenvalues in WR and WI. * DO 50 K = 1, N WR( K ) = T( K, K ) WI( K ) = ZERO 50 CONTINUE DO 60 K = 1, N - 1 IF( T( K+1, K ).NE.ZERO ) THEN WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* $ SQRT( ABS( T( K+1, K ) ) ) WI( K+1 ) = -WI( K ) END IF 60 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DTRSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtrsyl.f000066400000000000000000001054551522610125300263050ustar00rootroot00000000000000*> \brief \b DTRSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRSYL solves the real Sylvester matrix equation: *> *> op(A)*X + X*op(B) = scale*C or *> op(A)*X - X*op(B) = scale*C, *> *> where op(A) = A or A**T, and A and B are both upper quasi- *> triangular. A is M-by-M and B is N-by-N; the right hand side C and *> the solution X are M-by-N; and scale is an output scale factor, set *> <= 1 to avoid overflow in X. *> *> A and B must be in Schur canonical form (as returned by DHSEQR), that *> is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; *> each 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANA *> \verbatim *> TRANA is CHARACTER*1 *> Specifies the option op(A): *> = 'N': op(A) = A (No transpose) *> = 'T': op(A) = A**T (Transpose) *> = 'C': op(A) = A**H (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] TRANB *> \verbatim *> TRANB is CHARACTER*1 *> Specifies the option op(B): *> = 'N': op(B) = B (No transpose) *> = 'T': op(B) = B**T (Transpose) *> = 'C': op(B) = B**H (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> Specifies the sign in the equation: *> = +1: solve op(A)*X + X*op(B) = scale*C *> = -1: solve op(A)*X - X*op(B) = scale*C *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrix A, and the number of rows in the *> matrices X and C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B, and the number of columns in the *> matrices X and C. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,M) *> The upper quasi-triangular matrix A, in Schur canonical form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> The upper quasi-triangular matrix B, in Schur canonical form. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N right hand side matrix C. *> On exit, C is overwritten by the solution matrix X. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M) *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scale factor, scale, set <= 1 to avoid overflow in X. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: A and B have common or very close eigenvalues; perturbed *> values were used to solve the equation (but the matrices *> A and B are unchanged). *> \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 DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, 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 TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM, SUML, SUMR, XNORM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANGE EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSYL', -INFO ) RETURN END IF * * Quick return if possible * SCALE = ONE IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM * SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) * SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * * Start column loop (index = L) * L1 (L2) : column index of the first (first) row of X(K,L). * LNEXT = 1 DO 60 L = 1, N IF( L.LT.LNEXT ) $ GO TO 60 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L). * KNEXT = M DO 50 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 50 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 20 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 20 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 30 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 30 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2, $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 50 CONTINUE * 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A**T *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 T L-1 * R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = 1 DO 120 L = 1, N IF( L.LT.LNEXT ) $ GO TO 120 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 110 K = 1, M IF( K.LT.KNEXT ) $ GO TO 110 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 80 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 80 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 90 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 110 CONTINUE 120 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A**T*X + ISGN*X*B**T = scale*C. * * The (K,L)th block of X is determined starting from * top-right corner column by column by * * A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) * * Where * K-1 N * R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. * I=1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 180 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 180 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 170 K = 1, M IF( K.LT.KNEXT ) $ GO TO 170 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 130 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 130 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 140 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 150 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 160 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 160 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 170 CONTINUE 180 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B**T = scale*C. * * The (K,L)th block of X is determined starting from * bottom-right corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. * I=K+1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 240 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 240 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = M DO 230 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 230 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 190 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 200 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 200 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 210 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 210 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 220 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 220 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 230 CONTINUE 240 CONTINUE * END IF * RETURN * * End of DTRSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dtrti2.f000066400000000000000000000134231522610125300261650ustar00rootroot00000000000000*> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRTI2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRTI2 computes the inverse of a real upper or lower triangular *> matrix. *> *> This is the Level 2 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit 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 triangular matrix A. If UPLO = 'U', the *> leading n by n upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. If DIAG = 'U', the *> diagonal elements of A are also not referenced and are *> assumed to be 1. *> *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DTRMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, '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.NE.0 ) THEN CALL XERBLA( 'DTRTI2', -INFO ) RETURN END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE * * Compute inverse of lower triangular matrix. * DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF * RETURN * * End of DTRTI2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/dzsum1.f000066400000000000000000000063421522610125300262020ustar00rootroot00000000000000*> \brief \b DZSUM1 forms the 1-norm of the complex vector using the true absolute value. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DZSUM1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 CX( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DZSUM1 takes the sum of the absolute values of a complex *> vector and returns a double precision result. *> *> Based on DZASUM from the Level 1 BLAS. *> The change is to use the 'genuine' absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements in the vector CX. *> \endverbatim *> *> \param[in] CX *> \verbatim *> CX is COMPLEX*16 array, dimension (N) *> The vector whose elements will be summed. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The spacing between successive values of CX. INCX > 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham for use with ZLACON. * * ===================================================================== DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N * .. * .. Array Arguments .. COMPLEX*16 CX( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, NINCX DOUBLE PRECISION STEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * DZSUM1 = 0.0D0 STEMP = 0.0D0 IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 20 * * CODE FOR INCREMENT NOT EQUAL TO 1 * NINCX = N*INCX DO 10 I = 1, NINCX, INCX * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 10 CONTINUE DZSUM1 = STEMP RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 20 CONTINUE DO 30 I = 1, N * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 30 CONTINUE DZSUM1 = STEMP RETURN * * End of DZSUM1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/icmax1.f000066400000000000000000000066201522610125300261400ustar00rootroot00000000000000*> \brief \b ICMAX1 finds the index of the first vector element of maximum absolute value. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ICMAX1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ICMAX1( N, CX, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX CX( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ICMAX1 finds the index of the first vector element of maximum absolute value. *> *> Based on ICAMAX from Level 1 BLAS. *> The change is to use the 'genuine' absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements in the vector CX. *> \endverbatim *> *> \param[in] CX *> \verbatim *> CX is COMPLEX array, dimension (N) *> The vector CX. The ICMAX1 function returns the index of its first *> element of maximum absolute value. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The spacing between successive values of CX. INCX >= 1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date February 2014 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham for use with CLACON. * * ===================================================================== INTEGER FUNCTION ICMAX1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX CX(*) * .. * * ===================================================================== * * .. Local Scalars .. REAL SMAX INTEGER I, IX * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * ICMAX1 = 0 IF (N.LT.1 .OR. INCX.LE.0) RETURN ICMAX1 = 1 IF (N.EQ.1) RETURN IF (INCX.EQ.1) THEN * * code for increment equal to 1 * SMAX = ABS(CX(1)) DO I = 2,N IF (ABS(CX(I)).GT.SMAX) THEN ICMAX1 = I SMAX = ABS(CX(I)) END IF END DO ELSE * * code for increment not equal to 1 * IX = 1 SMAX = ABS(CX(1)) IX = IX + INCX DO I = 2,N IF (ABS(CX(IX)).GT.SMAX) THEN ICMAX1 = I SMAX = ABS(CX(IX)) END IF IX = IX + INCX END DO END IF RETURN * * End of ICMAX1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ieeeck.f000066400000000000000000000107241522610125300262030ustar00rootroot00000000000000*> \brief \b IEEECK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download IEEECK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * .. Scalar Arguments .. * INTEGER ISPEC * REAL ONE, ZERO * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> IEEECK is called from the ILAENV to verify that Infinity and *> possibly NaN arithmetic is safe (i.e. will not trap). *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is INTEGER *> Specifies whether to test just for inifinity arithmetic *> or whether to test for infinity and NaN arithmetic. *> = 0: Verify infinity arithmetic only. *> = 1: Verify infinity and NaN arithmetic. *> \endverbatim *> *> \param[in] ZERO *> \verbatim *> ZERO is REAL *> Must contain the value 0.0 *> This is passed to prevent the compiler from optimizing *> away this code. *> \endverbatim *> *> \param[in] ONE *> \verbatim *> ONE is REAL *> Must contain the value 1.0 *> This is passed to prevent the compiler from optimizing *> away this code. *> *> RETURN VALUE: INTEGER *> = 0: Arithmetic failed to produce the correct answers *> = 1: Arithmetic produced the correct answers *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * -- LAPACK auxiliary routine (version 3.7.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 ISPEC REAL ONE, ZERO * .. * * ===================================================================== * * .. Local Scalars .. REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, $ NEGZRO, NEWZRO, POSINF * .. * .. Executable Statements .. IEEECK = 1 * POSINF = ONE / ZERO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = -ONE / ZERO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGZRO = ONE / ( NEGINF+ONE ) IF( NEGZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGINF = ONE / NEGZRO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEWZRO = NEGZRO + ZERO IF( NEWZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = ONE / NEWZRO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = NEGINF*POSINF IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = POSINF*POSINF IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * * * * * Return if we were only asked to check infinity arithmetic * IF( ISPEC.EQ.0 ) $ RETURN * NAN1 = POSINF + NEGINF * NAN2 = POSINF / NEGINF * NAN3 = POSINF / POSINF * NAN4 = POSINF*ZERO * NAN5 = NEGINF*NEGZRO * NAN6 = NAN5*ZERO * IF( NAN1.EQ.NAN1 ) THEN IEEECK = 0 RETURN END IF * IF( NAN2.EQ.NAN2 ) THEN IEEECK = 0 RETURN END IF * IF( NAN3.EQ.NAN3 ) THEN IEEECK = 0 RETURN END IF * IF( NAN4.EQ.NAN4 ) THEN IEEECK = 0 RETURN END IF * IF( NAN5.EQ.NAN5 ) THEN IEEECK = 0 RETURN END IF * IF( NAN6.EQ.NAN6 ) THEN IEEECK = 0 RETURN END IF * RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilaclc.f000066400000000000000000000056521522610125300262110ustar00rootroot00000000000000*> \brief \b ILACLC scans a matrix for its last non-zero column. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILACLC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILACLC( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILACLC scans A for its last non-zero column. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILACLC( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) * .. * .. Local Scalars .. INTEGER I * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( N.EQ.0 ) THEN ILACLC = N ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILACLC = N ELSE * Now scan each column from the end, returning with the first non-zero. DO ILACLC = N, 1, -1 DO I = 1, M IF( A(I, ILACLC).NE.ZERO ) RETURN END DO END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilaclr.f000066400000000000000000000057251522610125300262310ustar00rootroot00000000000000*> \brief \b ILACLR scans a matrix for its last non-zero row. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILACLR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILACLR( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILACLR scans A for its last non-zero row. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILACLR( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( M.EQ.0 ) THEN ILACLR = M ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILACLR = M ELSE * Scan up each column tracking the last zero row seen. ILACLR = 0 DO J = 1, N I=M DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) I=I-1 ENDDO ILACLR = MAX( ILACLR, I ) END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/iladlc.f000066400000000000000000000056421522610125300262110ustar00rootroot00000000000000*> \brief \b ILADLC scans a matrix for its last non-zero column. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILADLC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLC( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILADLC scans A for its last non-zero column. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLC( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( N.EQ.0 ) THEN ILADLC = N ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILADLC = N ELSE * Now scan each column from the end, returning with the first non-zero. DO ILADLC = N, 1, -1 DO I = 1, M IF( A(I, ILADLC).NE.ZERO ) RETURN END DO END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/iladlr.f000066400000000000000000000057251522610125300262320ustar00rootroot00000000000000*> \brief \b ILADLR scans a matrix for its last non-zero row. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILADLR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLR( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILADLR scans A for its last non-zero row. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLR( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( M.EQ.0 ) THEN ILADLR = M ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILADLR = M ELSE * Scan up each column tracking the last zero row seen. ILADLR = 0 DO J = 1, N I=M DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) I=I-1 ENDDO ILADLR = MAX( ILADLR, I ) END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilaenv.f000066400000000000000000000477221522610125300262440ustar00rootroot00000000000000*> \brief \b ILAENV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILAENV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ILAENV is called from the LAPACK routines to choose problem-dependent *> parameters for the local environment. See ISPEC for a description of *> the parameters. *> *> ILAENV returns an INTEGER *> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC *> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. *> *> This version provides a set of parameters which should give good, *> but not optimal, performance on many of the currently available *> computers. Users are encouraged to modify this subroutine to set *> the tuning parameters for their particular machine using the option *> and problem size information in the arguments. *> *> This routine will not function correctly if it is converted to all *> lower case. Converting it to all upper case is allowed. *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is INTEGER *> Specifies the parameter to be returned as the value of *> ILAENV. *> = 1: the optimal blocksize; if this value is 1, an unblocked *> algorithm will give the best performance. *> = 2: the minimum block size for which the block routine *> should be used; if the usable block size is less than *> this value, an unblocked routine should be used. *> = 3: the crossover point (in a block routine, for N less *> than this value, an unblocked routine should be used) *> = 4: the number of shifts, used in the nonsymmetric *> eigenvalue routines (DEPRECATED) *> = 5: the minimum column dimension for blocking to be used; *> rectangular blocks must have dimension at least k by m, *> where k is given by ILAENV(2,...) and m by ILAENV(5,...) *> = 6: the crossover point for the SVD (when reducing an m by n *> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds *> this value, a QR factorization is used first to reduce *> the matrix to a triangular form.) *> = 7: the number of processors *> = 8: the crossover point for the multishift QR method *> for nonsymmetric eigenvalue problems (DEPRECATED) *> = 9: maximum size of the subproblems at the bottom of the *> computation tree in the divide-and-conquer algorithm *> (used by xGELSD and xGESDD) *> =10: ieee NaN arithmetic can be trusted not to trap *> =11: infinity arithmetic can be trusted not to trap *> 12 <= ISPEC <= 16: *> xHSEQR or related subroutines, *> see IPARMQ for detailed explanation *> \endverbatim *> *> \param[in] NAME *> \verbatim *> NAME is CHARACTER*(*) *> The name of the calling subroutine, in either upper case or *> lower case. *> \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] N1 *> \verbatim *> N1 is INTEGER *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> \endverbatim *> *> \param[in] N3 *> \verbatim *> N3 is INTEGER *> \endverbatim *> *> \param[in] N4 *> \verbatim *> N4 is INTEGER *> Problem dimensions for the subroutine NAME; these may not all *> be required. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The following conventions have been used when calling ILAENV from the *> LAPACK routines: *> 1) OPTS is a concatenation of all of the character options to *> subroutine NAME, in the same order that they appear in the *> argument list for NAME, even if they are not used in determining *> the value of the parameter specified by ISPEC. *> 2) The problem dimensions N1, N2, N3, N4 are specified in the order *> that they appear in the argument list for NAME. N1 is used *> first, N2 second, and so on, and unused problem dimensions are *> passed a value of -1. *> 3) The parameter value returned by ILAENV is checked for validity in *> the calling subroutine. For example, ILAENV is used to retrieve *> the optimal blocksize for STRTRI as follows: *> *> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) *> IF( NB.LE.1 ) NB = MAX( 1, N ) *> \endverbatim *> * ===================================================================== INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * * -- LAPACK auxiliary routine (version 3.7.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*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IC, IZ, NB, NBMIN, NX LOGICAL CNAME, SNAME CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. 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, $ 170, 170, 170, 170, 170 )ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 10 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 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 20 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) 20 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 30 I = 2, 6 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 ) 30 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 40 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) 40 CONTINUE END IF END IF * C1 = SUBNAM( 1: 1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) C4 = C3( 2: 3 ) * GO TO ( 50, 60, 70 )ISPEC * 50 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 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 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 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 IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF ELSE IF( C2.EQ.'GG' ) THEN NB = 32 IF( C3.EQ.'HD3' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF END IF END IF ILAENV = NB RETURN * 60 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. $ 'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'GG' ) THEN NBMIN = 2 IF( C3.EQ.'HD3' ) THEN NBMIN = 2 END IF END IF ILAENV = NBMIN RETURN * 70 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. $ 'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NX = 128 END IF END IF ELSE IF( C2.EQ.'GG' ) THEN NX = 128 IF( C3.EQ.'HD3' ) THEN NX = 128 END IF END IF ILAENV = NX RETURN * 80 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 90 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 100 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 110 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 120 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * 130 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * ILAENV = 25 RETURN * 140 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * * ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * 150 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * * ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * 160 CONTINUE * * 12 <= ISPEC <= 16: xHSEQR or related subroutines. * 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 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilaslc.f000066400000000000000000000056321522610125300262270ustar00rootroot00000000000000*> \brief \b ILASLC scans a matrix for its last non-zero column. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILASLC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILASLC( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILASLC scans A for its last non-zero column. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILASLC( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( N.EQ.0 ) THEN ILASLC = N ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILASLC = N ELSE * Now scan each column from the end, returning with the first non-zero. DO ILASLC = N, 1, -1 DO I = 1, M IF( A(I, ILASLC).NE.ZERO ) RETURN END DO END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilaslr.f000066400000000000000000000057141522610125300262470ustar00rootroot00000000000000*> \brief \b ILASLR scans a matrix for its last non-zero row. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILASLR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILASLR( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILASLR scans A for its last non-zero row. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILASLR( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( M.EQ.0 ) THEN ILASLR = M ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILASLR = M ELSE * Scan up each column tracking the last zero row seen. ILASLR = 0 DO J = 1, N I=M DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) I=I-1 ENDDO ILASLR = MAX( ILASLR, I ) END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilazlc.f000066400000000000000000000056571522610125300262450ustar00rootroot00000000000000*> \brief \b ILAZLC scans a matrix for its last non-zero column. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILAZLC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAZLC( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILAZLC scans A for its last non-zero column. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILAZLC( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) * .. * .. Local Scalars .. INTEGER I * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( N.EQ.0 ) THEN ILAZLC = N ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILAZLC = N ELSE * Now scan each column from the end, returning with the first non-zero. DO ILAZLC = N, 1, -1 DO I = 1, M IF( A(I, ILAZLC).NE.ZERO ) RETURN END DO END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ilazlr.f000066400000000000000000000057421522610125300262570ustar00rootroot00000000000000*> \brief \b ILAZLR scans a matrix for its last non-zero row. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILAZLR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAZLR( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILAZLR scans A for its last non-zero row. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> 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 * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILAZLR( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 M, N, LDA * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( M.EQ.0 ) THEN ILAZLR = M ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILAZLR = M ELSE * Scan up each column tracking the last zero row seen. ILAZLR = 0 DO J = 1, N I=M DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) I=I-1 ENDDO ILAZLR = MAX( ILAZLR, I ) END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/iparam2stage.F000066400000000000000000000276141522610125300273030ustar00rootroot00000000000000*> \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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/iparmq.f000066400000000000000000000334301522610125300262460ustar00rootroot00000000000000*> \brief \b IPARMQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download IPARMQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> This program sets problem and machine dependent parameters *> useful for xHSEQR and related subroutines for eigenvalue *> problems. It is called whenever *> IPARMQ is called with 12 <= ISPEC <= 16 *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is INTEGER *> ISPEC specifies which tunable parameter IPARMQ should *> return. *> *> ISPEC=12: (INMIN) Matrices of order nmin or less *> are sent directly to xLAHQR, the implicit *> double shift QR algorithm. NMIN must be *> at least 11. *> *> ISPEC=13: (INWIN) Size of the deflation window. *> This is best set greater than or equal to *> the number of simultaneous shifts NS. *> Larger matrices benefit from larger deflation *> windows. *> *> ISPEC=14: (INIBL) Determines when to stop nibbling and *> invest in an (expensive) multi-shift QR sweep. *> If the aggressive early deflation subroutine *> finds LD converged eigenvalues from an order *> NW deflation window and LD.GT.(NW*NIBBLE)/100, *> then the next QR sweep is skipped and early *> deflation is applied immediately to the *> remaining active diagonal block. Setting *> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a *> multi-shift QR sweep whenever early deflation *> finds a converged eigenvalue. Setting *> IPARMQ(ISPEC=14) greater than or equal to 100 *> prevents TTQRE from skipping a multi-shift *> QR sweep. *> *> ISPEC=15: (NSHFTS) The number of simultaneous shifts in *> a multi-shift QR iteration. *> *> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the *> following meanings. *> 0: During the multi-shift QR/QZ sweep, *> blocked eigenvalue reordering, blocked *> Hessenberg-triangular reduction, *> reflections and/or rotations are not *> accumulated when updating the *> far-from-diagonal matrix entries. *> 1: During the multi-shift QR/QZ sweep, *> blocked eigenvalue reordering, blocked *> Hessenberg-triangular reduction, *> reflections and/or rotations are *> accumulated, and matrix-matrix *> multiplication is used to update the *> far-from-diagonal matrix entries. *> 2: During the multi-shift QR/QZ sweep, *> blocked eigenvalue reordering, blocked *> Hessenberg-triangular reduction, *> reflections and/or rotations are *> accumulated, and 2-by-2 block structure *> is exploited during matrix-matrix *> multiplies. *> (If xTRMM is slower than xGEMM, then *> IPARMQ(ISPEC=16)=1 may be more efficient than *> IPARMQ(ISPEC=16)=2 despite the greater level of *> arithmetic work implied by the latter choice.) *> \endverbatim *> *> \param[in] NAME *> \verbatim *> NAME is character string *> Name of the calling subroutine *> \endverbatim *> *> \param[in] OPTS *> \verbatim *> OPTS is character string *> This is a concatenation of the string arguments to *> TTQRE. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> N is the order of the Hessenberg matrix H. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The amount of workspace available. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Little is known about how best to choose these parameters. *> It is possible to use different values of the parameters *> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. *> *> It is probably best to choose different parameters for *> different matrices and different parameters at different *> times during the iteration, but this has not been *> implemented --- yet. *> *> *> The best choices of most of the parameters depend *> in an ill-understood way on the relative execution *> rate of xLAQR3 and xLAQR5 and on the nature of each *> particular eigenvalue problem. Experiment may be the *> only practical way to determine which choices are most *> effective. *> *> Following is a list of default values supplied by IPARMQ. *> These defaults may be adjusted in order to attain better *> performance in any particular computational environment. *> *> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> IPARMQ(ISPEC=13) Recommended deflation window size. *> This depends on ILO, IHI and NS, the *> number of simultaneous shifts returned *> by IPARMQ(ISPEC=15). The default for *> (IHI-ILO+1).LE.500 is NS. The default *> for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. *> *> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. *> a multi-shift QR iteration. *> *> If IHI-ILO+1 is ... *> *> greater than ...but less ... the *> or equal to ... than default is *> *> 0 30 NS = 2+ *> 30 60 NS = 4+ *> 60 150 NS = 10 *> 150 590 NS = ** *> 590 3000 NS = 64 *> 3000 6000 NS = 128 *> 6000 infinity NS = 256 *> *> (+) By default matrices of this order are *> passed to the implicit double shift routine *> xLAHQR. See IPARMQ(ISPEC=12) above. These *> values of NS are used only in case of a rare *> xLAHQR failure. *> *> (**) The asterisks (**) indicate an ad-hoc *> function increasing from 10 to 64. *> *> IPARMQ(ISPEC=16) Select structured matrix multiply. *> (See ISPEC=16 above for details.) *> Default: 3. *> \endverbatim *> * ===================================================================== INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER IHI, ILO, ISPEC, LWORK, N CHARACTER NAME*( * ), OPTS*( * ) * * ================================================================ * .. Parameters .. INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, $ ISHFTS = 15, IACC22 = 16 ) INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, $ NIBBLE = 14, KNWSWP = 500 ) REAL TWO PARAMETER ( TWO = 2.0 ) * .. * .. Local Scalars .. INTEGER NH, NS INTEGER I, IC, IZ CHARACTER SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC LOG, MAX, MOD, NINT, REAL * .. * .. Executable Statements .. IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. $ ( ISPEC.EQ.IACC22 ) ) THEN * * ==== Set the number simultaneous shifts ==== * NH = IHI - ILO + 1 NS = 2 IF( NH.GE.30 ) $ NS = 4 IF( NH.GE.60 ) $ NS = 10 IF( NH.GE.150 ) $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) IF( NH.GE.590 ) $ NS = 64 IF( NH.GE.3000 ) $ NS = 128 IF( NH.GE.6000 ) $ NS = 256 NS = MAX( 2, NS-MOD( NS, 2 ) ) END IF * IF( ISPEC.EQ.INMIN ) THEN * * * ===== Matrices of order smaller than NMIN get sent * . to xLAHQR, the classic double shift algorithm. * . This must be at least 11. ==== * IPARMQ = NMIN * ELSE IF( ISPEC.EQ.INIBL ) THEN * * ==== INIBL: skip a multi-shift qr iteration and * . whenever aggressive early deflation finds * . at least (NIBBLE*(window size)/100) deflations. ==== * IPARMQ = NIBBLE * ELSE IF( ISPEC.EQ.ISHFTS ) THEN * * ==== NSHFTS: The number of simultaneous shifts ===== * IPARMQ = NS * ELSE IF( ISPEC.EQ.INWIN ) THEN * * ==== NW: deflation window size. ==== * IF( NH.LE.KNWSWP ) THEN IPARMQ = NS ELSE IPARMQ = 3*NS / 2 END IF * ELSE IF( ISPEC.EQ.IACC22 ) THEN * * ==== IACC22: Whether to accumulate reflections * . before updating the far-from-diagonal elements * . and whether to use 2-by-2 block structure while * . doing it. A small amount of work could be saved * . by making this choice dependent also upon the * . NH=IHI-ILO+1. * * * Convert NAME to upper case if the first character is lower case. * IPARMQ = 0 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 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) END DO 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 I = 2, 6 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 ) END DO 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 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) END DO END IF END IF * IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN IPARMQ = 1 IF( NH.GE.K22MIN ) $ IPARMQ = 2 ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN IF( NH.GE.KACMIN ) $ IPARMQ = 1 IF( NH.GE.K22MIN ) $ IPARMQ = 2 ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN IF( NS.GE.KACMIN ) $ IPARMQ = 1 IF( NS.GE.K22MIN ) $ IPARMQ = 2 END IF * ELSE * ===== invalid value of ispec ===== IPARMQ = -1 * END IF * * ==== End of IPARMQ ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/izmax1.f000066400000000000000000000066231522610125300261720ustar00rootroot00000000000000*> \brief \b IZMAX1 finds the index of the first vector element of maximum absolute value. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download IZMAX1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IZMAX1( N, ZX, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 ZX( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> IZMAX1 finds the index of the first vector element of maximum absolute value. *> *> Based on IZAMAX from Level 1 BLAS. *> The change is to use the 'genuine' absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements in the vector ZX. *> \endverbatim *> *> \param[in] ZX *> \verbatim *> ZX is COMPLEX*16 array, dimension (N) *> The vector ZX. The IZMAX1 function returns the index of its first *> element of maximum absolute value. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The spacing between successive values of ZX. INCX >= 1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date February 2014 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham for use with ZLACON. * * ===================================================================== INTEGER FUNCTION IZMAX1( N, ZX, INCX ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 ZX(*) * .. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION DMAX INTEGER I, IX * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IZMAX1 = 0 IF (N.LT.1 .OR. INCX.LE.0) RETURN IZMAX1 = 1 IF (N.EQ.1) RETURN IF (INCX.EQ.1) THEN * * code for increment equal to 1 * DMAX = ABS(ZX(1)) DO I = 2,N IF (ABS(ZX(I)).GT.DMAX) THEN IZMAX1 = I DMAX = ABS(ZX(I)) END IF END DO ELSE * * code for increment not equal to 1 * IX = 1 DMAX = ABS(ZX(1)) IX = IX + INCX DO I = 2,N IF (ABS(ZX(IX)).GT.DMAX) THEN IZMAX1 = I DMAX = ABS(ZX(IX)) END IF IX = IX + INCX END DO END IF RETURN * * End of IZMAX1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/lsame.f000066400000000000000000000062061522610125300260570ustar00rootroot00000000000000*> \brief \b LSAME * * =========== DOCUMENTATION =========== * * 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: * ============= *> *> \verbatim *> *> LSAME returns .TRUE. if CA is the same letter as CB regardless of *> case. *> \endverbatim * * Arguments: * ========== * *> \param[in] CA *> \verbatim *> \endverbatim *> *> \param[in] CB *> \verbatim *> CA and CB specify the single characters to be compared. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 3.7.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 CA, CB * .. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * ! WRITE(*,*) "CA =", CA, " CB = ", CB LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/lsamen.f000066400000000000000000000057221522610125300262370ustar00rootroot00000000000000*> \brief \b LSAMEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download LSAMEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION LSAMEN( N, CA, CB ) * * .. Scalar Arguments .. * CHARACTER*( * ) CA, CB * INTEGER N * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> LSAMEN tests if the first N letters of CA are the same as the *> first N letters of CB, regardless of case. *> LSAMEN returns .TRUE. if CA and CB are equivalent except for case *> and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) *> or LEN( CB ) is less than N. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of characters in CA and CB to be compared. *> \endverbatim *> *> \param[in] CA *> \verbatim *> CA is CHARACTER*(*) *> \endverbatim *> *> \param[in] CB *> \verbatim *> CB is CHARACTER*(*) *> CA and CB specify two character strings of length at least N. *> Only the first N characters of each string will be accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION LSAMEN( N, CA, CB ) * * -- LAPACK auxiliary routine (version 3.7.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*( * ) CA, CB INTEGER N * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC LEN * .. * .. Executable Statements .. * LSAMEN = .FALSE. IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) $ GO TO 20 * * Do for each character in the two strings. * DO 10 I = 1, N * * Test if the characters are equal using LSAME. * IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) ) $ GO TO 20 * 10 CONTINUE LSAMEN = .TRUE. * 20 CONTINUE RETURN * * End of LSAMEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/saxpby.f000066400000000000000000000065631522610125300262720ustar00rootroot00000000000000*> \brief \b SAXPY * * =========== DOCUMENTATION =========== * * 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 * .. * .. Array Arguments .. * REAL SX(*),SY(*) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SAXPY constant times a vector plus a vector. *> uses unrolled loops for increments equal to one. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> number of elements in input vector(s) *> \endverbatim *> *> \param[in] SA *> \verbatim *> SA is REAL *> On entry, SA specifies the scalar alpha. *> \endverbatim *> *> \param[in] SX *> \verbatim *> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> storage spacing between elements of SX *> \endverbatim *> *> \param[in,out] SY *> \verbatim *> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> storage spacing between elements of SY *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup single_blas_level1 * *> \par Further Details: * ===================== *> *> \verbatim *> *> jack dongarra, linpack, 3/11/78. *> modified 12/3/93, array(1) declarations changed to array(*) *> \endverbatim *> * ===================================================================== SUBROUTINE SAXPBY(N,SA,SX,INCX,SB,SY,INCY) * * -- Reference BLAS level1 routine (version 3.8.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. REAL SA,SB INTEGER INCX,INCY,N * .. * .. Array Arguments .. REAL SX(*),SY(*) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I,IX,IY,M,MP1 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. IF (N.LE.0) RETURN IF (SA.EQ.0.0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN * * code for both increments equal to 1 * * * clean-up loop * M = MOD(N,4) IF (M.NE.0) THEN DO I = 1,M SY(I) = SB*SY(I) + SA*SX(I) END DO END IF IF (N.LT.4) RETURN MP1 = M + 1 DO I = MP1,N,4 SY(I) = SB * SY(I) + SA*SX(I) SY(I+1) = SB * SY(I+1) + SA*SX(I+1) SY(I+2) = SB * SY(I+2) + SA*SX(I+2) SY(I+3) = SB * SY(I+3) + SA*SX(I+3) END DO ELSE * * code for unequal increments or equal increments * not equal to 1 * IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N SY(IY) = SB* SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY END DO END IF RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/scsum1.f000066400000000000000000000063351522610125300261740ustar00rootroot00000000000000*> \brief \b SCSUM1 forms the 1-norm of the complex vector using the true absolute value. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SCSUM1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SCSUM1( N, CX, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX CX( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SCSUM1 takes the sum of the absolute values of a complex *> vector and returns a single precision result. *> *> Based on SCASUM from the Level 1 BLAS. *> The change is to use the 'genuine' absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements in the vector CX. *> \endverbatim *> *> \param[in] CX *> \verbatim *> CX is COMPLEX array, dimension (N) *> The vector whose elements will be summed. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The spacing between successive values of CX. INCX > 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complexOTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham for use with CLACON. * * ===================================================================== REAL FUNCTION SCSUM1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N * .. * .. Array Arguments .. COMPLEX CX( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, NINCX REAL STEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * SCSUM1 = 0.0E0 STEMP = 0.0E0 IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 20 * * CODE FOR INCREMENT NOT EQUAL TO 1 * NINCX = N*INCX DO 10 I = 1, NINCX, INCX * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 10 CONTINUE SCSUM1 = STEMP RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 20 CONTINUE DO 30 I = 1, N * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 30 CONTINUE SCSUM1 = STEMP RETURN * * End of SCSUM1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sdsdot.f000066400000000000000000000151461522610125300262610ustar00rootroot00000000000000*> \brief \b SDSDOT * * =========== DOCUMENTATION =========== * * 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 * .. * .. 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 * ========= * * 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) * 890831 REVISION DATE from Version 3.2 * 891214 Prologue converted to Version 4.0 format. (BAB) * 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 * .. * .. Intrinsic Functions .. * INTRINSIC DBLE * .. * DSDOT = SB * IF (N.LE.0) THEN * SDSDOT = DSDOT * RETURN * 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 * IF (INCY.LT.0) KY = 1 + (1-N)*INCY * DO I = 1,N * DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) * KX = KX + INCX * KY = KY + INCY * END DO * END IF * SDSDOT = DSDOT * RETURN * END * *> \par Purpose: * ============= *> *> \verbatim *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup single_blas_level1 * * ===================================================================== REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) * * -- 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..-- * December 2016 * * .. Scalar Arguments .. REAL SB INTEGER INCX,INCY,N * .. * .. 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 * ========= * * 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) * 890831 REVISION DATE from Version 3.2 * 891214 Prologue converted to Version 4.0 format. (BAB) * 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 * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. DSDOT = SB IF (N.LE.0) THEN SDSDOT = DSDOT RETURN 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 IF (INCY.LT.0) KY = 1 + (1-N)*INCY DO I = 1,N DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) KX = KX + INCX KY = KY + INCY END DO END IF SDSDOT = DSDOT RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgebak.f000066400000000000000000000160401522610125300262070ustar00rootroot00000000000000*> \brief \b SGEBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL V( LDV, * ), SCALE( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEBAK forms the right or left eigenvectors of a real general matrix *> by backward transformation on the computed eigenvectors of the *> balanced matrix output by SGEBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N', do nothing, return immediately; *> = 'P', do backward transformation for permutation only; *> = 'S', do backward transformation for scaling only; *> = 'B', do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to SGEBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by SGEBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] SCALE *> \verbatim *> SCALE is REAL array, dimension (N) *> Details of the permutation and scaling factors, as returned *> by SGEBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is REAL array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by SHSEIN or STREVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= 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 realGEcomputational * * ===================================================================== SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. REAL V( LDV, * ), SCALE( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K REAL S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SSCAL, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL SSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL SSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of SGEBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgebal.f000066400000000000000000000244441522610125300262170ustar00rootroot00000000000000*> \brief \b SGEBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * REAL A( LDA, * ), SCALE( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEBAL balances a general real matrix A. This involves, first, *> permuting A by a similarity transformation to isolate eigenvalues *> in the first 1 to ILO-1 and last IHI+1 to N elements on the *> diagonal; and second, applying a diagonal similarity transformation *> to rows and columns ILO to IHI to make the rows and columns as *> close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrix, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A: *> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 *> for i = 1,...,N; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A is not referenced. *> 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] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL array, dimension (N) *> Details of the permutations and scaling factors applied to *> A. If P(j) is the index of the row and column interchanged *> with row and column j and D(j) is the scaling factor *> applied to row and column j, then *> SCALE(j) = P(j) for j = 1,...,ILO-1 *> = D(j) for j = ILO,...,IHI *> = P(j) for j = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-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 realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The permutations consist of row and column interchanges which put *> the matrix in the form *> *> ( T1 X Y ) *> P A P = ( 0 B Z ) *> ( 0 0 T2 ) *> *> where T1 and T2 are upper triangular matrices whose eigenvalues lie *> along the diagonal. The column indices ILO and IHI mark the starting *> and ending columns of the submatrix B. Balancing consists of applying *> a diagonal similarity transformation inv(D) * B * D to make the *> 1-norms of each row of B and its corresponding column nearly equal. *> The output matrix is *> *> ( T1 X*D Y ) *> ( 0 inv(D)*B*D inv(D)*Z ). *> ( 0 0 T2 ) *> *> Information about the permutations P and the diagonal matrix D is *> returned in the vector SCALE. *> *> This subroutine is based on the EISPACK routine BALANC. *> *> Modified by Tzu-Yi Chen, Computer Science Division, University of *> California at Berkeley, USA *> \endverbatim *> * ===================================================================== SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. REAL A( LDA, * ), SCALE( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL SCLFAC PARAMETER ( SCLFAC = 2.0E+0 ) REAL FACTOR PARAMETER ( FACTOR = 0.95E+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 * .. * .. External Functions .. LOGICAL SISNAN, LSAME INTEGER ISAMAX REAL SLAMCH, SNRM2 EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH, SNRM2 * .. * .. External Subroutines .. EXTERNAL SSCAL, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) 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( 'SGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL SSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( A( J, I ).NE.ZERO ) $ GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( A( I, J ).NE.ZERO ) $ GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = SLAMCH( 'S' ) / SLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L * C = SNRM2( L-K+1, A( K, I ), 1 ) R = SNRM2( L-K+1, A( I, K ), LDA ) ICA = ISAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = ISAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 IF( SISNAN( C+F+CA+R+G+RA ) ) THEN * * Exit if NaN to avoid infinite loop * INFO = -3 CALL XERBLA( 'SGEBAL', -INFO ) RETURN END IF F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL SSCAL( N-K+1, G, A( I, K ), LDA ) CALL SSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of SGEBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgebd2.f000066400000000000000000000233361522610125300261270ustar00rootroot00000000000000*> \brief \b SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEBD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEBD2 reduces a real general m by n matrix A to upper or lower *> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the orthogonal matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the orthogonal matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the orthogonal matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the orthogonal matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is REAL array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is REAL array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (max(M,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 June 2017 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); *> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); *> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 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 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'SGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) A( I, I ) = ONE * * Apply H(i) to A(i:m,i+1:n) from the left * IF( I.LT.N ) $ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * CALL SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) A( I, I+1 ) = E( I ) ELSE TAUP( I ) = ZERO END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = A( I, I ) A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) $ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAUP( I ), A( I+1, I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(i+1:m,i+1:n) from the left * CALL SLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), $ A( I+1, I+1 ), LDA, WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of SGEBD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgebrd.f000066400000000000000000000256351522610125300262330ustar00rootroot00000000000000*> \brief \b SGEBRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEBRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEBRD reduces a general real M-by-N matrix A to upper or lower *> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the M-by-N general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the orthogonal matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the orthogonal matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the orthogonal matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the orthogonal matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is REAL array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is REAL array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \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 >= max(1,M,N). *> For optimum performance LWORK >= (M+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 November 2017 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); *> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors; *> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); *> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX, WS * .. * .. External Subroutines .. EXTERNAL SGEBD2, SGEMM, SLABRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = REAL( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'SGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'SGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, 'SGEBRD', ' ', M, N, -1, -1 ) IF( LWORK.GE.( M+N )*NBMIN ) THEN NB = LWORK / ( M+N ) ELSE NB = 1 NX = MINMN END IF END IF END IF ELSE NX = MINMN END IF * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+nb-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * CALL SLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, $ WORK( LDWRKX*NB+1 ), LDWRKY ) * * Update the trailing submatrix A(i+nb:m,i+nb:n), using an update * of the form A := A - V*Y**T - X*U**T * CALL SGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, A( I+NB, I ), LDA, $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, $ A( I+NB, I+NB ), LDA ) CALL SGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 10 J = I, I + NB - 1 A( J, J ) = D( J ) A( J, J+1 ) = E( J ) 10 CONTINUE ELSE DO 20 J = I, I + NB - 1 A( J, J ) = D( J ) A( J+1, J ) = E( J ) 20 CONTINUE END IF 30 CONTINUE * * Use unblocked code to reduce the remainder of the matrix * CALL SGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, IINFO ) WORK( 1 ) = WS RETURN * * End of SGEBRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgees.f000066400000000000000000000417201522610125300260640ustar00rootroot00000000000000*> \brief SGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * .. Function Arguments .. * LOGICAL SELECT * EXTERNAL SELECT * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEES computes for an N-by-N real nonsymmetric matrix A, the *> eigenvalues, the real Schur form T, and, optionally, the matrix of *> Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). *> *> Optionally, it also orders the eigenvalues on the diagonal of the *> real Schur form so that selected eigenvalues are at the top left. *> The leading columns of Z then form an orthonormal basis for the *> invariant subspace corresponding to the selected eigenvalues. *> *> A matrix is in real Schur form if it is upper quasi-triangular with *> 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the *> form *> [ a b ] *> [ c a ] *> *> where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVS *> \verbatim *> JOBVS is CHARACTER*1 *> = 'N': Schur vectors are not computed; *> = 'V': Schur vectors are computed. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELECT). *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> 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. *> If SORT = 'N', SELECT is not referenced. *> An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if *> SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex *> conjugate pair of eigenvalues is selected, then both complex *> eigenvalues are selected. *> Note that a selected complex eigenvalue may no longer *> satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since *> ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned); in this *> case INFO is set to N+2 (see INFO below). *> \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 N-by-N matrix A. *> On exit, A has been overwritten by its real Schur form T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELECT is true. (Complex conjugate *> pairs for which SELECT is true for either *> eigenvalue count as 2.) *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is REAL array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL array, dimension (N) *> WR and WI contain the real and imaginary parts, *> respectively, of the computed eigenvalues in the same order *> that they appear on the diagonal of the output Schur form T. *> Complex conjugate pairs of eigenvalues will appear *> consecutively with the eigenvalue having the positive *> imaginary part first. *> \endverbatim *> *> \param[out] VS *> \verbatim *> VS is REAL array, dimension (LDVS,N) *> If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur *> vectors. *> If JOBVS = 'N', VS is not referenced. *> \endverbatim *> *> \param[in] LDVS *> \verbatim *> LDVS is INTEGER *> The leading dimension of the array VS. LDVS >= 1; if *> JOBVS = 'V', LDVS >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) contains the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,3*N). *> For good performance, LWORK must generally be larger. *> *> 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] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \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 i is *> <= N: the QR algorithm failed to compute all the *> eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI *> contain those eigenvalues which have converged; if *> JOBVS = 'V', VS contains the matrix which reduces A *> to its partially converged Schur form. *> = N+1: the eigenvalues could not be reordered because some *> eigenvalues were too close to separate (the problem *> is very ill-conditioned); *> = N+2: after reordering, roundoff changed values of some *> complex eigenvalues so that leading eigenvalues in *> the Schur form no longer satisfy SELECT=.TRUE. This *> could also be caused by underflow due to scaling. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup realGEeigen * * ===================================================================== SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER JOBVS, SORT INTEGER INFO, LDA, LDVS, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), $ WR( * ) * .. * .. Function Arguments .. LOGICAL SELECT EXTERNAL SELECT * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, $ WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, $ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK REAL ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) REAL DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, $ SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANGE EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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. * HSWORK refers to the workspace preferred by SHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 ) MINWRK = 3*N * CALL SHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, $ WORK, -1, IEVAL ) HSWORK = WORK( 1 ) * IF( .NOT.WANTVS ) THEN MAXWRK = MAX( MAXWRK, N + HSWORK ) ELSE MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'SORGHR', ' ', N, 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, N + HSWORK ) END IF END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = SLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need N) * IBAL = 1 CALL SGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (Workspace: need 3*N, prefer 2*N+N*NB) * ITAU = N + IBAL IWRK = N + ITAU CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVS ) THEN * * Copy Householder vectors to VS * CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS ) * * Generate orthogonal matrix in VS * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL SORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) END IF * SDIM = 0 * * Perform QR iteration, accumulating Schur vectors in VS if desired * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL SHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) IF( IEVAL.GT.0 ) $ INFO = IEVAL * * Sort eigenvalues if desired * IF( WANTST .AND. INFO.EQ.0 ) THEN IF( SCALEA ) THEN CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR ) CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR ) END IF DO 10 I = 1, N BWORK( I ) = SELECT( WR( I ), WI( I ) ) 10 CONTINUE * * Reorder eigenvalues and transform Schur vectors * (Workspace: none needed) * CALL STRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, $ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ ICOND ) IF( ICOND.GT.0 ) $ INFO = N + ICOND END IF * IF( WANTVS ) THEN * * Undo balancing * (Workspace: need N) * CALL SGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, $ IERR ) END IF * IF( SCALEA ) THEN * * Undo scaling for the Schur form of A * CALL SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) CALL SCOPY( N, A, LDA+1, WR, 1 ) IF( CSCALE.EQ.SMLNUM ) THEN * * If scaling back towards underflow, adjust WI if an * offdiagonal element of a 2-by-2 block in the Schur form * underflows. * IF( IEVAL.GT.0 ) THEN I1 = IEVAL + 1 I2 = IHI - 1 CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, $ MAX( ILO-1, 1 ), IERR ) ELSE IF( WANTST ) THEN I1 = 1 I2 = N - 1 ELSE I1 = ILO I2 = IHI - 1 END IF INXT = I1 - 1 DO 20 I = I1, I2 IF( I.LT.INXT ) $ GO TO 20 IF( WI( I ).EQ.ZERO ) THEN INXT = I + 1 ELSE IF( A( I+1, I ).EQ.ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. $ ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO IF( I.GT.1 ) $ CALL SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 ) IF( N.GT.I+1 ) $ CALL SSWAP( N-I-1, A( I, I+2 ), LDA, $ A( I+1, I+2 ), LDA ) IF( WANTVS ) THEN CALL SSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 ) END IF A( I, I+1 ) = A( I+1, I ) A( I+1, I ) = ZERO END IF INXT = I + 2 END IF 20 CONTINUE END IF * * Undo scaling for the imaginary part of the eigenvalues * CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR ) END IF * IF( WANTST .AND. INFO.EQ.0 ) THEN * * Check if reordering successful * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 30 I = 1, N CURSL = SELECT( WR( I ), WI( I ) ) IF( WI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 30 CONTINUE END IF * WORK( 1 ) = MAXWRK RETURN * * End of SGEES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgegs.f000066400000000000000000000414111522610125300260630ustar00rootroot00000000000000*> \brief SGEGS computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine SGGES. *> *> SGEGS computes the eigenvalues, real Schur form, and, optionally, *> 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 *> is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal *> 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 *> (GNEP). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors (returned in VSL). *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors (returned in VSR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA, N) *> On entry, the matrix A. *> On exit, the upper quasi-triangular matrix S from the *> generalized real Schur factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is REAL array, dimension (LDB, N) *> On entry, the matrix B. *> On exit, the upper triangular matrix T from the generalized *> real Schur factorization. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is REAL array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is REAL array, dimension (N) *> The imaginary parts of each scalar alpha defining an *> eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th *> eigenvalue is real; if positive, then the j-th and (j+1)-st *> eigenvalues are a complex conjugate pair, with *> ALPHAI(j+1) = -ALPHAI(j). *> \endverbatim *> *> \param[out] BETA *> \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 *> mu = beta/alpha. Since either lambda or mu may overflow, *> they should not, in general, be computed. *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is REAL array, dimension (LDVSL,N) *> If JOBVSL = 'V', the matrix of left Schur vectors Q. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is REAL array, dimension (LDVSR,N) *> If JOBVSR = 'V', the matrix of right Schur vectors Z. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. LWORK >= max(1,4*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: *> NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR *> The optimal LWORK is 2*N + N*(NB+1). *> *> 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. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from SGGBAL *> =N+2: error return from SGEQRF *> =N+3: error return from SORMQR *> =N+4: error return from SORGQR *> =N+5: error return from SGGHRD *> =N+6: error return from SHGEQZ (other than failed *> iteration) *> =N+7: error return from SGGBAK (computing VSL) *> =N+8: error return from SGGBAK (computing VSR) *> =N+9: error return from SLASCL (various places) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEeigen * * ===================================================================== SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, 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 JOBVSL, JOBVSR INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, $ ILO, IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN, $ LWKOPT, NB, NB1, NB2, NB3 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SAFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY, $ SLASCL, SLASET, SORGQR, SORMQR, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANGE EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * * Test the input arguments * LWKMIN = MAX( 4*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -12 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -14 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -16 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = 2*N+N*(NB+1) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEGS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = SLAMCH( 'E' )*SLAMCH( 'B' ) SAFMIN = SLAMCH( 'S' ) SMLNUM = N*SAFMIN / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = SLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) THEN CALL SLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = SLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) THEN CALL SLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * Workspace layout: (2*N words -- "work..." not actually used) * left_permutation, right_permutation, work... * ILEFT = 1 IRIGHT = N + 1 IWORK = IRIGHT + N CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 10 END IF * * Reduce B to triangular form, and initialize VSL and/or VSR * Workspace layout: ("work..." must have at least N words) * left_permutation, right_permutation, tau, work... * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWORK IWORK = ITAU + IROWS CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 10 END IF * CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 10 END IF * IF( ILVSL ) THEN CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 10 END IF END IF * IF( ILVSR ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 10 END IF * * Perform QZ algorithm, computing Schur vectors if desired * Workspace layout: ("work..." must have at least 1 word) * left_permutation, right_permutation, work... * IWORK = ITAU CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 10 END IF * * Apply permutation to VSL and VSR * IF( ILVSL ) THEN CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 10 END IF END IF IF( ILVSR ) THEN CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 10 END IF END IF * * Undo scaling * IF( ILASCL ) THEN CALL SLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * IF( ILBSCL ) THEN CALL SLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL SLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * 10 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of SGEGS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgehd2.f000066400000000000000000000146301522610125300261320ustar00rootroot00000000000000*> \brief \b SGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEHD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGEHD2 reduces a real general matrix A to upper Hessenberg form H by *> an orthogonal similarity transformation: Q**T * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to SGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= max(1,N). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the n by n general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is REAL array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL 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 realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL AII * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) AII = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i) to A(i+1:ihi,i+1:n) from the left * CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), $ A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = AII 10 CONTINUE * RETURN * * End of SGEHD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgehrd.f000066400000000000000000000251351522610125300262340ustar00rootroot00000000000000*> \brief \b SGEHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGEHRD reduces a real general matrix A to upper Hessenberg form H by *> an orthogonal similarity transformation: Q**T * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to SGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is REAL array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to *> zero. *> \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 >= max(1,N). *> 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 *> 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 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This file is a slight modification of LAPACK-3.0's DGEHRD *> subroutine incorporating improvements proposed by Quintana-Orti and *> Van de Geijn (2006). (See DLAHR2.) *> \endverbatim *> * ===================================================================== SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, $ ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX REAL EI * .. * .. External Subroutines .. EXTERNAL SAXPY, SGEHD2, SGEMM, SLAHR2, SLARFB, STRMM, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 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 ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'SGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'SGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code * IF( LWORK.LT.N*NB+TSIZE ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'SGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN NB = (LWORK-TSIZE) / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * IWT = 1 + N*NB DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V**T * which performs the reduction, and also the matrix Y = A*V*T * CALL SLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), $ WORK( IWT ), LDT, WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE 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 ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the * right * CALL STRMM( 'Right', 'Lower', 'Transpose', $ 'Unit', I, IB-1, $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) DO 30 J = 0, IB-2 CALL SAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, $ A( 1, I+J+1 ), 1 ) 30 CONTINUE * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL SLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, $ WORK( IWT ), LDT, A( I+1, I+IB ), LDA, $ WORK, LDWORK ) 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL SGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = LWKOPT * RETURN * * End of SGEHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgelq2.f000066400000000000000000000117531522610125300261560ustar00rootroot00000000000000*> \brief \b SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGELQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGELQ2 computes an LQ factorization of a real m by n matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k) . . . H(2) H(1), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGELQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K REAL AII * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), $ A( I+1, I ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of SGELQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgelqf.f000066400000000000000000000165361522610125300262460ustar00rootroot00000000000000*> \brief \b SGELQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGELQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGELQF computes an LQ factorization of a real M-by-N matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \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. LWORK >= max(1,M). *> For optimum performance LWORK >= M*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 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k) . . . H(2) H(1), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGELQF( M, N, A, LDA, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL SGELQ2, SLARFB, SLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'SGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'SGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL SGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL SLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL SLARFB( 'Right', 'No transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL SGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of SGELQF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgelqt.f000066400000000000000000000121531522610125300262530ustar00rootroot00000000000000* 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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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/MB), where each *> block is of order MB except for the last block, which is of order *> IB = K - (B-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-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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, SGELQT3, 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgelqt3.f000066400000000000000000000146341522610125300263440ustar00rootroot00000000000000* 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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. REAL A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+00 ) * .. * .. Local Scalars .. INTEGER I, I1, J, J1, M1, M2, IINFO * .. * .. External Subroutines .. EXTERNAL SLARFG, STRMM, SGEMM, 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgemlqt.f000066400000000000000000000163131522610125300264320ustar00rootroot00000000000000* 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 *> *> DGEMLQT 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,M) if SIDE = 'L', *> (LDV,N) if SIDE = 'R' *> 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. LDV >= max(1,K). *> \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-K 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 November 2017 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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 * .. * .. 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 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgemqr.f000066400000000000000000000171651522610125300262620ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgemqrt.f000066400000000000000000000174701522610125300264450ustar00rootroot00000000000000*> \brief \b SGEMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEMQRT 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 SGEQRT. *> *> 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; *> = 'T': 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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CGEQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension (LDV,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRT in the first K columns 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 CGEQRT, stored as a NB-by-N matrix. *> \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, 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*NB if SIDE = 'L', or M*NB 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 realGEcomputational * * ===================================================================== SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, 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, NB, 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, 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 LDWORK = MAX( 1, N ) Q = M ELSE IF ( RIGHT ) THEN LDWORK = MAX( 1, M ) Q = N 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 .OR. K.GT.Q ) THEN INFO = -5 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * 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, $ 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * 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, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * ELSE IF( RIGHT .AND. TRAN ) THEN * 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * END IF * RETURN * * End of SGEMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqp3.f000066400000000000000000000236121522610125300261600ustar00rootroot00000000000000*> \brief \b SGEQP3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEQP3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGEQP3 computes a QR factorization with column pivoting of a *> matrix A: A*P = Q*R using Level 3 BLAS. *> \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 upper triangle of the array contains the *> min(M,N)-by-N upper trapezoidal matrix R; the elements below *> the diagonal, together with the array TAU, represent the *> orthogonal matrix Q as a product of min(M,N) elementary *> reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(J).ne.0, the J-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(J)=0, *> the J-th column of A is a free column. *> On exit, if JPVT(J)=K, then the J-th column of A*P was the *> the K-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \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. LWORK >= 3*N+1. *> For optimal performance LWORK >= 2*N+( 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real/complex vector *> with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in *> A(i+1:m,i), and tau in TAU(i). *> \endverbatim * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> * ===================================================================== SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN * .. * .. External Subroutines .. EXTERNAL SGEQRF, SLAQP2, SLAQPS, SORMQR, SSWAP, XERBLA * .. * .. External Functions .. INTEGER ILAENV REAL SNRM2 EXTERNAL ILAENV, SNRM2 * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * Test input arguments * ==================== * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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 END IF * IF( INFO.EQ.0 ) THEN MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN IWS = 1 LWKOPT = 1 ELSE IWS = 3*N + 1 NB = ILAENV( INB, 'SGEQRF', ' ', M, N, -1, -1 ) LWKOPT = 2*N + ( N + 1 )*NB END IF WORK( 1 ) = LWKOPT * IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQP3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Move initial columns up front. * NFXD = 1 DO 10 J = 1, N IF( JPVT( J ).NE.0 ) THEN IF( J.NE.NFXD ) THEN CALL SSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) JPVT( J ) = JPVT( NFXD ) JPVT( NFXD ) = J ELSE JPVT( J ) = J END IF NFXD = NFXD + 1 ELSE JPVT( J ) = J END IF 10 CONTINUE NFXD = NFXD - 1 * * Factorize fixed columns * ======================= * * Compute the QR factorization of fixed columns and update * remaining columns. * IF( NFXD.GT.0 ) THEN NA = MIN( M, NFXD ) *CC CALL SGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL SGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) IF( NA.LT.N ) THEN *CC CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, *CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) CALL SORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU, $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) END IF END IF * * Factorize free columns * ====================== * IF( NFXD.LT.MINMN ) THEN * SM = M - NFXD SN = N - NFXD SMINMN = MINMN - NFXD * * Determine the block size. * NB = ILAENV( INB, 'SGEQRF', ' ', SM, SN, -1, -1 ) NBMIN = 2 NX = 0 * IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( IXOVER, 'SGEQRF', ' ', SM, SN, -1, $ -1 ) ) * * IF( NX.LT.SMINMN ) THEN * * Determine if workspace is large enough for blocked code. * MINWS = 2*SN + ( SN+1 )*NB IWS = MAX( IWS, MINWS ) IF( LWORK.LT.MINWS ) THEN * * Not enough workspace to use optimal NB: Reduce NB and * determine the minimum value of NB. * NB = ( LWORK-2*SN ) / ( SN+1 ) NBMIN = MAX( 2, ILAENV( INBMIN, 'SGEQRF', ' ', SM, SN, $ -1, -1 ) ) * * END IF END IF END IF * * Initialize partial column norms. The first N elements of work * store the exact column norms. * DO 20 J = NFXD + 1, N WORK( J ) = SNRM2( SM, A( NFXD+1, J ), 1 ) WORK( N+J ) = WORK( J ) 20 CONTINUE * IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. $ ( NX.LT.SMINMN ) ) THEN * * Use blocked code initially. * J = NFXD + 1 * * Compute factorization: while loop. * * TOPBMN = MINMN - NX 30 CONTINUE IF( J.LE.TOPBMN ) THEN JB = MIN( NB, TOPBMN-J+1 ) * * Factorize JB columns among columns J:N. * CALL SLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) * J = J + FJB GO TO 30 END IF ELSE J = NFXD + 1 END IF * * Use unblocked code to factor the last or only block. * * IF( J.LE.MINMN ) $ CALL SLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), $ TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ) ) * END IF * WORK( 1 ) = IWS RETURN * * End of SGEQP3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqpf.f000066400000000000000000000211271522610125300262420ustar00rootroot00000000000000*> \brief \b SGEQPF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEQPF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine SGEQP3. *> *> SGEQPF computes a QR factorization with column pivoting of a *> real M-by-N matrix A: A*P = 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. 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 upper triangle of the array contains the *> min(M,N)-by-N upper triangular matrix R; the elements *> below the diagonal, together with the array TAU, *> represent the orthogonal matrix Q as a product of *> min(m,n) elementary reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (3*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 realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(n) *> *> Each H(i) has the form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). *> *> The matrix P is represented in jpvt as follows: If *> jpvt(j) = i *> then the jth column of P is the ith canonical unit vector. *> *> Partial column norm updating strategy modified by *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. *> -- April 2011 -- *> For more details see LAPACK Working Note 176. *> \endverbatim *> * ===================================================================== SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, 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, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT REAL AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL SGEQR2, SLARF, SLARFG, SORM2R, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SLAMCH, SNRM2 EXTERNAL ISAMAX, SLAMCH, SNRM2 * .. * .. 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQPF', -INFO ) RETURN END IF * MN = MIN( M, N ) TOL3Z = SQRT(SLAMCH('Epsilon')) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL SSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL SGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL SORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU, $ A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n elements of * work store the exact column norms. * DO 20 I = ITEMP + 1, N WORK( I ) = SNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) WORK( N+I ) = WORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + ISAMAX( N-I+1, WORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i) * IF( I.LT.M ) THEN CALL SLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE CALL SLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN * * 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( M-I.GT.0 ) THEN WORK( J ) = SNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = ZERO WORK( N+J ) = ZERO END IF ELSE WORK( J ) = WORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of SGEQPF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqr.f000066400000000000000000000224761522610125300261060ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqr2.f000066400000000000000000000117441522610125300261640ustar00rootroot00000000000000*> \brief \b SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGEQR2 computes a QR factorization of a real m by n matrix A: *> 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. 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL 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 realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGEQR2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K REAL AII * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of SGEQR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqrt.f000066400000000000000000000136721522610125300262700ustar00rootroot00000000000000*> \brief \b SGEQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGEQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGEQRT computes a blocked QR 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] NB *> \verbatim *> NB is INTEGER *> The block size to be used in the blocked QR. MIN(M,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 min(M,N)-by-N upper trapezoidal matrix R (R is *> upper triangular if M >= N); the elements below the diagonal *> are the columns 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 >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (NB*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 June 2017 * *> \ingroup realGEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. REAL A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, IINFO, K LOGICAL USE_RECURSIVE_QR PARAMETER( USE_RECURSIVE_QR=.TRUE. ) * .. * .. 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( NB.LT.1 .OR. ( NB.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.NB ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQRT', -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, 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 CALL SGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) ELSE CALL SGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) END IF IF( I+IB.LE.N ) THEN * * 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+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN * * End of SGEQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqrt2.f000066400000000000000000000140401522610125300263400ustar00rootroot00000000000000*> \brief \b SGEQRT2 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/ * *> \htmlonly *> Download SGEQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> \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 *> 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. *> \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 realGEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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. *> \endverbatim *> * ===================================================================== SUBROUTINE SGEQRT2( 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, LDT, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER( ONE = 1.0, ZERO = 0.0 ) * .. * .. Local Scalars .. INTEGER I, K REAL AII, ALPHA * .. * .. External Subroutines .. EXTERNAL SLARFG, SGEMV, SGER, STRMV, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQRT2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO I = 1, K * * Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) * CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ T( I, 1 ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(I:M,I+1:N) from the left * AII = A( I, I ) A( I, I ) = ONE * * 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, $ 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, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF END DO * DO I = 2, N AII = A( I, I ) A( I, I ) = ONE * * 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, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL STRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO * * End of SGEQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgeqrt3.f000066400000000000000000000161651522610125300263530ustar00rootroot00000000000000*> \brief \b SGEQRT3 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/ * *> \htmlonly *> Download SGEQRT3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> *> 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 *> 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. *> \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 June 2016 * *> \ingroup realGEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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 SGEQRT3( 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..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. REAL A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0 ) * .. * .. Local Scalars .. INTEGER I, I1, J, J1, N1, N2, IINFO * .. * .. External Subroutines .. EXTERNAL SLARFG, STRMM, SGEMM, XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N .LT. 0 ) THEN INFO = -2 ELSE IF( M .LT. N ) THEN INFO = -1 ELSE IF( LDA .LT. MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT .LT. MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEQRT3', -INFO ) RETURN END IF * IF( N.EQ.1 ) THEN * * Compute Householder transform when N=1 * CALL SLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) * ELSE * * Otherwise, split A into blocks... * N1 = N/2 N2 = N-N1 J1 = MIN( N1+1, N ) I1 = MIN( N+1, M ) * * Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H * CALL SGEQRT3( M, N1, A, LDA, T, LDT, IINFO ) * * Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] * DO J=1,N2 DO I=1,N1 T( I, J+N1 ) = A( I, J+N1 ) END DO END DO 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, & A( J1, J1 ), LDA, ONE, T( 1, J1 ), LDT) * 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, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL STRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * DO J=1,N2 DO I=1,N1 A( I, J+N1 ) = A( I, J+N1 ) - T( I, J+N1 ) END DO END DO * * 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, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 * DO I=1,N1 DO J=1,N2 T( I, J+N1 ) = (A( J+N1, I )) END DO END DO * 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, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), 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, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] * [ 0 R2 ] [ 0 T2] * END IF * RETURN * * End of SGEQRT3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgerq2.f000066400000000000000000000121211522610125300261520ustar00rootroot00000000000000*> \brief \b SGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGERQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SGERQ2 computes an RQ factorization of a real m by n matrix A: *> A = R * 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,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the m by n matrix A. *> On exit, if m <= n, the upper triangle of the subarray *> A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; *> if m >= n, the elements on and above the (m-n)-th subdiagonal *> contain the m by n upper trapezoidal matrix R; the remaining *> elements, 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in *> A(m-k+i,1:n-k+i-1), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SGERQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K REAL AII * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGERQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = K, 1, -1 * * Generate elementary reflector H(i) to annihilate * A(m-k+i,1:n-k+i-1) * CALL SLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * AII = A( M-K+I, N-K+I ) A( M-K+I, N-K+I ) = ONE CALL SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, $ TAU( I ), A, LDA, WORK ) A( M-K+I, N-K+I ) = AII 10 CONTINUE RETURN * * End of SGERQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgesc2.f000066400000000000000000000124351522610125300261450ustar00rootroot00000000000000*> \brief \b SGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGESC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * .. Scalar Arguments .. * INTEGER LDA, N * REAL SCALE * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * REAL A( LDA, * ), RHS( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGESC2 solves a system of linear equations *> *> A * X = scale* RHS *> *> with a general N-by-N matrix A using the LU factorization with *> complete pivoting computed by SGETC2. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the LU part of the factorization of the n-by-n *> matrix A computed by SGETC2: A = P * L * U * Q *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is REAL array, dimension (N). *> On entry, the right hand side vector b. *> On exit, the solution vector X. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit, SCALE contains the scale factor. SCALE is chosen *> 0 <= SCALE <= 1 to prevent owerflow in the solution. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, N REAL SCALE * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) REAL A( LDA, * ), RHS( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, TWO PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL BIGNUM, EPS, SMLNUM, TEMP * .. * .. External Subroutines .. EXTERNAL SLABAD, SLASWP, SSCAL * .. * .. External Functions .. INTEGER ISAMAX REAL SLAMCH EXTERNAL ISAMAX, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Set constant to control owerflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) * * Apply permutations IPIV to RHS * CALL SLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) * * Solve for L part * DO 20 I = 1, N - 1 DO 10 J = I + 1, N RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) 10 CONTINUE 20 CONTINUE * * Solve for U part * SCALE = ONE * * Check for scaling * I = ISAMAX( N, RHS, 1 ) IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN TEMP = ( ONE / TWO ) / ABS( RHS( I ) ) CALL SSCAL( N, TEMP, RHS( 1 ), 1 ) SCALE = SCALE*TEMP END IF * DO 40 I = N, 1, -1 TEMP = ONE / A( I, I ) RHS( I ) = RHS( I )*TEMP DO 30 J = I + 1, N RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) 30 CONTINUE 40 CONTINUE * * Apply permutations JPIV to the solution (RHS) * CALL SLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) RETURN * * End of SGESC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgetc2.f000066400000000000000000000141771522610125300261530ustar00rootroot00000000000000*> \brief \b SGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGETC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGETC2 computes an LU factorization with complete pivoting of the *> n-by-n matrix A. The factorization has the form A = P * L * U * Q, *> where P and Q are permutation matrices, L is lower triangular with *> unit diagonal elements and U is upper triangular. *> *> This is the Level 2 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \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 n-by-n matrix A to be factored. *> On exit, the factors L and U from the factorization *> A = P*L*U*Q; the unit diagonal elements of L are not stored. *> If U(k, k) appears to be less than SMIN, U(k, k) is given the *> value of SMIN, i.e., giving a nonsingular perturbed system. *> \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). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension(N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = k, U(k, k) is likely to produce owerflow if *> we try to solve for x in Ax = b. So U is perturbed to *> avoid the overflow. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) REAL A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, IP, IPV, J, JP, JPV REAL BIGNUM, EPS, SMIN, SMLNUM, XMAX * .. * .. External Subroutines .. EXTERNAL SGER, SLABAD, SSWAP * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) * * Handle the case N=1 by itself * IF( N.EQ.1 ) THEN IPIV( 1 ) = 1 JPIV( 1 ) = 1 IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN INFO = 1 A( 1, 1 ) = SMLNUM END IF RETURN END IF * * Factorize A using complete pivoting. * Set pivots less than SMIN to SMIN. * DO 40 I = 1, N - 1 * * Find max element in matrix A * XMAX = ZERO DO 20 IP = I, N DO 10 JP = I, N IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( A( IP, JP ) ) IPV = IP JPV = JP END IF 10 CONTINUE 20 CONTINUE IF( I.EQ.1 ) $ SMIN = MAX( EPS*XMAX, SMLNUM ) * * Swap rows * IF( IPV.NE.I ) $ CALL SSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) IPIV( I ) = IPV * * Swap columns * IF( JPV.NE.I ) $ CALL SSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) JPIV( I ) = JPV * * Check for singularity * IF( ABS( A( I, I ) ).LT.SMIN ) THEN INFO = I A( I, I ) = SMIN END IF DO 30 J = I + 1, N A( J, I ) = A( J, I ) / A( I, I ) 30 CONTINUE CALL SGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA, $ A( I+1, I+1 ), LDA ) 40 CONTINUE * IF( ABS( A( N, N ) ).LT.SMIN ) THEN INFO = N A( N, N ) = SMIN END IF * * Set last pivots to N * IPIV( N ) = N JPIV( N ) = N * RETURN * * End of SGETC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sggbak.f000066400000000000000000000201441522610125300262110ustar00rootroot00000000000000*> \brief \b SGGBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGGBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGGBAK forms the right or left eigenvectors of a real generalized *> eigenvalue problem A*x = lambda*B*x, by backward transformation on *> the computed eigenvectors of the balanced pair of matrices output by *> SGGBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N': do nothing, return immediately; *> = 'P': do backward transformation for permutation only; *> = 'S': do backward transformation for scaling only; *> = 'B': do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to SGGBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by SGGBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] LSCALE *> \verbatim *> LSCALE is REAL array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the left side of A and B, as returned by SGGBAL. *> \endverbatim *> *> \param[in] RSCALE *> \verbatim *> RSCALE is REAL array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the right side of A and B, as returned by SGGBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is REAL array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by STGEVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the matrix V. LDV >= 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 realGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. Ward, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. REAL LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SSCAL, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN INFO = -4 ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) $ THEN INFO = -5 ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward transformation on right eigenvectors * IF( RIGHTV ) THEN DO 10 I = ILO, IHI CALL SSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) 10 CONTINUE END IF * * Backward transformation on left eigenvectors * IF( LEFTV ) THEN DO 20 I = ILO, IHI CALL SSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) 20 CONTINUE END IF END IF * * Backward permutation * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward permutation on right eigenvectors * IF( RIGHTV ) THEN IF( ILO.EQ.1 ) $ GO TO 50 * DO 40 I = ILO - 1, 1, -1 K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE * 50 CONTINUE IF( IHI.EQ.N ) $ GO TO 70 DO 60 I = IHI + 1, N K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 60 CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 60 CONTINUE END IF * * Backward permutation on left eigenvectors * 70 CONTINUE IF( LEFTV ) THEN IF( ILO.EQ.1 ) $ GO TO 90 DO 80 I = ILO - 1, 1, -1 K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 80 CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 80 CONTINUE * 90 CONTINUE IF( IHI.EQ.N ) $ GO TO 110 DO 100 I = IHI + 1, N K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 100 CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 100 CONTINUE END IF END IF * 110 CONTINUE * RETURN * * End of SGGBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sggbal.f000066400000000000000000000365101522610125300262160ustar00rootroot00000000000000*> \brief \b SGGBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGGBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), LSCALE( * ), * $ RSCALE( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGGBAL balances a pair of general real matrices (A,B). This *> involves, first, permuting A and B by similarity transformations to *> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N *> elements on the diagonal; and second, applying a diagonal similarity *> transformation to rows and columns ILO to IHI to make the rows *> and columns as close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrices, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors in the *> generalized eigenvalue problem A*x = lambda*B*x. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A and B: *> = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 *> and RSCALE(I) = 1.0 for i = 1,...,N. *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A 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,out] B *> \verbatim *> B is REAL array, dimension (LDB,N) *> On entry, the input matrix B. *> On exit, B is overwritten by the balanced matrix. *> If JOB = 'N', B is not referenced. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 and B(i,j) = 0 if i > j and *> j = 1,...,ILO-1 or i = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] LSCALE *> \verbatim *> LSCALE is REAL array, dimension (N) *> Details of the permutations and scaling factors applied *> to the left side of A and B. If P(j) is the index of the *> row interchanged with row j, and D(j) *> is the scaling factor applied to row j, then *> LSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] RSCALE *> \verbatim *> RSCALE is REAL array, dimension (N) *> Details of the permutations and scaling factors applied *> to the right side of A and B. If P(j) is the index of the *> column interchanged with column j, and D(j) *> is the scaling factor applied to column j, then *> LSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL 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 *> *> \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 realGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. WARD, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), LSCALE( * ), $ RSCALE( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 ) REAL THREE, SCLFAC PARAMETER ( THREE = 3.0E+0, SCLFAC = 1.0E+1 ) * .. * .. Local Scalars .. INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, $ M, NR, NRP2 REAL ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC * .. * .. External Functions .. LOGICAL LSAME INTEGER ISAMAX REAL SDOT, SLAMCH EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH * .. * .. External Subroutines .. EXTERNAL SAXPY, SSCAL, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG10, MAX, MIN, REAL, SIGN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGBAL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * IF( N.EQ.1 ) THEN ILO = 1 IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N DO 10 I = 1, N LSCALE( I ) = ONE RSCALE( I ) = ONE 10 CONTINUE RETURN END IF * K = 1 L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * GO TO 30 * * Permute the matrices A and B to isolate the eigenvalues. * * Find row with one nonzero in columns 1 through L * 20 CONTINUE L = LM1 IF( L.NE.1 ) $ GO TO 30 * RSCALE( 1 ) = ONE LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE LM1 = L - 1 DO 80 I = L, 1, -1 DO 40 J = 1, LM1 JP1 = J + 1 IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 50 40 CONTINUE J = L GO TO 70 * 50 CONTINUE DO 60 J = JP1, L IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 80 60 CONTINUE J = JP1 - 1 * 70 CONTINUE M = L IFLOW = 1 GO TO 160 80 CONTINUE GO TO 100 * * Find column with one nonzero in rows K through N * 90 CONTINUE K = K + 1 * 100 CONTINUE DO 150 J = K, L DO 110 I = K, LM1 IP1 = I + 1 IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 120 110 CONTINUE I = L GO TO 140 120 CONTINUE DO 130 I = IP1, L IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 150 130 CONTINUE I = IP1 - 1 140 CONTINUE M = K IFLOW = 2 GO TO 160 150 CONTINUE GO TO 190 * * Permute rows M and I * 160 CONTINUE LSCALE( M ) = I IF( I.EQ.M ) $ GO TO 170 CALL SSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) CALL SSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) * * Permute columns M and J * 170 CONTINUE RSCALE( M ) = J IF( J.EQ.M ) $ GO TO 180 CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL SSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) * 180 CONTINUE GO TO ( 20, 90 )IFLOW * 190 CONTINUE ILO = K IHI = L * IF( LSAME( JOB, 'P' ) ) THEN DO 195 I = ILO, IHI LSCALE( I ) = ONE RSCALE( I ) = ONE 195 CONTINUE RETURN END IF * IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 DO 200 I = ILO, IHI RSCALE( I ) = ZERO LSCALE( I ) = ZERO * WORK( I ) = ZERO WORK( I+N ) = ZERO WORK( I+2*N ) = ZERO WORK( I+3*N ) = ZERO WORK( I+4*N ) = ZERO WORK( I+5*N ) = ZERO 200 CONTINUE * * Compute right side vector in resulting linear equations * BASL = LOG10( SCLFAC ) DO 240 I = ILO, IHI DO 230 J = ILO, IHI TB = B( I, J ) TA = A( I, J ) IF( TA.EQ.ZERO ) $ GO TO 210 TA = LOG10( ABS( TA ) ) / BASL 210 CONTINUE IF( TB.EQ.ZERO ) $ GO TO 220 TB = LOG10( ABS( TB ) ) / BASL 220 CONTINUE WORK( I+4*N ) = WORK( I+4*N ) - TA - TB WORK( J+5*N ) = WORK( J+5*N ) - TA - TB 230 CONTINUE 240 CONTINUE * COEF = ONE / REAL( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO IT = 1 * * Start generalized conjugate gradient iteration * 250 CONTINUE * GAMMA = SDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + $ SDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) * EW = ZERO EWC = ZERO DO 260 I = ILO, IHI EW = EW + WORK( I+4*N ) EWC = EWC + WORK( I+5*N ) 260 CONTINUE * GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC-THREE*EW ) TC = COEF5*( EW-THREE*EWC ) * CALL SSCAL( NR, BETA, WORK( ILO ), 1 ) CALL SSCAL( NR, BETA, WORK( ILO+N ), 1 ) * CALL SAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) CALL SAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) * DO 270 I = ILO, IHI WORK( I ) = WORK( I ) + TC WORK( I+N ) = WORK( I+N ) + T 270 CONTINUE * * Apply matrix to vector * DO 300 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 290 J = ILO, IHI IF( A( I, J ).EQ.ZERO ) $ GO TO 280 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 280 CONTINUE IF( B( I, J ).EQ.ZERO ) $ GO TO 290 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 290 CONTINUE WORK( I+2*N ) = REAL( KOUNT )*WORK( I+N ) + SUM 300 CONTINUE * DO 330 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 320 I = ILO, IHI IF( A( I, J ).EQ.ZERO ) $ GO TO 310 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 310 CONTINUE IF( B( I, J ).EQ.ZERO ) $ GO TO 320 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 320 CONTINUE WORK( J+3*N ) = REAL( KOUNT )*WORK( J ) + SUM 330 CONTINUE * SUM = SDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + $ SDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) ALPHA = GAMMA / SUM * * Determine correction to current iteration * CMAX = ZERO DO 340 I = ILO, IHI COR = ALPHA*WORK( I+N ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR COR = ALPHA*WORK( I ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( I ) = RSCALE( I ) + COR 340 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 350 * CALL SAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) CALL SAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) * PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 250 * * End generalized conjugate gradient iteration * 350 CONTINUE SFMIN = SLAMCH( 'S' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) DO 360 I = ILO, IHI IRAB = ISAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) IRAB = ISAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR ICAB = ISAMAX( IHI, A( 1, I ), 1 ) CAB = ABS( A( ICAB, I ) ) ICAB = ISAMAX( IHI, B( 1, I ), 1 ) CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( I ) = SCLFAC**JC 360 CONTINUE * * Row scaling of matrices A and B * DO 370 I = ILO, IHI CALL SSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) CALL SSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) 370 CONTINUE * * Column scaling of matrices A and B * DO 380 J = ILO, IHI CALL SSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) CALL SSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) 380 CONTINUE * RETURN * * End of SGGBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgges.f000066400000000000000000000540771522610125300260770ustar00rootroot00000000000000*> \brief SGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGGES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), *> the generalized eigenvalues, the generalized real Schur form (S,T), *> optionally, the left and/or right matrices of Schur vectors (VSL and *> VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> quasi-triangular matrix S and the upper triangular matrix T.The *> leading columns of VSL and VSR then form an orthonormal basis for the *> corresponding left and right eigenspaces (deflating subspaces). *> *> (If only the generalized eigenvalues are needed, use the driver *> SGGEV instead, which is faster.) *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0 or both being zero. *> *> A pair of matrices (S,T) is in generalized real Schur form if T is *> upper triangular with non-negative diagonal and S is block upper *> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond *> to real generalized eigenvalues, while 2-by-2 blocks of S will be *> "standardized" by making the corresponding elements of T have the *> form: *> [ a 0 ] *> [ 0 b ] *> *> and the pair of corresponding 2-by-2 blocks in S and T will have a *> complex conjugate pair of generalized eigenvalues. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG); *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of three REAL arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if *> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either *> one of a complex conjugate pair of eigenvalues is selected, *> then both complex eigenvalues are selected. *> *> Note that in the ill-conditioned case, a selected complex *> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), *> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 *> in this case. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is REAL array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. (Complex conjugate pairs for which *> SELCTG is true for either eigenvalue count as 2.) *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is REAL array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is REAL array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is REAL array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real Schur form of (A,B) were further reduced to *> triangular form using 2-by-2 complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio. *> However, ALPHAR and ALPHAI will be always less than and *> usually comparable with norm(A) in magnitude, and BETA always *> less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is REAL array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is REAL array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. *> If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16). *> For good performance , LWORK must generally be larger. *> *> 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] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in SHGEQZ. *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in STGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEeigen * * ===================================================================== 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.7.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 JOBVSL, JOBVSR, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, LST2SL, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, $ MINWRK REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, $ PVSR, SAFMAX, SAFMIN, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) REAL DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD, $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANGE EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -15 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -17 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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.) * IF( INFO.EQ.0 ) THEN IF( N.GT.0 )THEN MINWRK = MAX( 8*N, 6*N + 16 ) MAXWRK = MINWRK - N + $ N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) ) IF( ILVSL ) THEN MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) ) END IF ELSE MINWRK = 1 MAXWRK = 1 END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = SLAMCH( 'P' ) SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) SMLNUM = SQRT( SAFMIN ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = SLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = SLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need 6*N + 2*N space for storing balancing factors) * ILEFT = 1 IRIGHT = N + 1 IWRK = IRIGHT + N CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWRK IWRK = ITAU + IROWS CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Workspace: need N, prefer N*NB) * CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * (Workspace: need N, prefer N*NB) * IF( ILVSL ) THEN CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IERR ) * * Perform QZ algorithm, computing Schur vectors if desired * (Workspace: need N) * IWRK = ITAU CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWRK ), LWORK+1-IWRK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 40 END IF * * Sort eigenvalues ALPHA/BETA if desired * (Workspace: need 4*N+16 ) * SDIM = 0 IF( WANTST ) THEN * * Undo scaling on eigenvalues before SELCTGing * IF( ILASCL ) THEN CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IERR ) CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IERR ) END IF IF( ILBSCL ) $ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) 10 CONTINUE * CALL STGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ IERR ) IF( IERR.EQ.1 ) $ INFO = N + 3 * END IF * * Apply back-permutation to VSL and VSR * (Workspace: none needed) * IF( ILVSL ) $ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) * IF( ILVSR ) $ 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 * 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 IF( ( ALPHAR( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR. $ ( 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 ) .OR. $ ( SAFMIN/ALPHAI( I ) ).GT.( ANRM/ANRMTO ) ) THEN WORK( 1 ) = ABS( A( I, I+1 )/ALPHAI( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 50 CONTINUE END IF * IF( ILBSCL )THEN DO 60 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I )/SAFMAX ).GT.( BNRMTO/BNRM ) .OR. $ ( SAFMIN/BETA( I ) ).GT.( BNRM/BNRMTO ) ) THEN WORK( 1 ) = ABS(B( I, I )/BETA( I )) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 60 CONTINUE END IF * * Undo scaling * IF( ILASCL ) THEN CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 30 I = 1, N CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) IF( ALPHAI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 30 CONTINUE * END IF * 40 CONTINUE * WORK( 1 ) = MAXWRK * RETURN * * End of SGGES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sgghrd.f000066400000000000000000000250121522610125300262300ustar00rootroot00000000000000*> \brief \b SGGHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SGGHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SGGHRD reduces a pair of real matrices (A,B) to generalized upper *> Hessenberg form using orthogonal transformations, where A is a *> general matrix and B is upper triangular. The form of the *> generalized eigenvalue problem is *> A*x = lambda*B*x, *> and B is typically made upper triangular by computing its QR *> factorization and moving the orthogonal matrix Q to the left side *> of the equation. *> *> This subroutine simultaneously reduces A to a Hessenberg matrix H: *> Q**T*A*Z = H *> and transforms B to another upper triangular matrix T: *> Q**T*B*Z = T *> in order to reduce the problem to its standard form *> H*y = lambda*T*y *> where y = Z**T*x. *> *> The orthogonal matrices Q and Z are determined as products of Givens *> rotations. They may either be formed explicitly, or they may be *> postmultiplied into input matrices Q1 and Z1, so that *> *> Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T *> *> Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T *> *> If Q1 is the orthogonal matrix from the QR factorization of B in the *> original equation A*x = lambda*B*x, then SGGHRD reduces the original *> problem to generalized Hessenberg form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': do not compute Q; *> = 'I': Q is initialized to the unit matrix, and the *> orthogonal matrix Q is returned; *> = 'V': Q must contain an orthogonal matrix Q1 on entry, *> and the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': do not compute Z; *> = 'I': Z is initialized to the unit matrix, and the *> orthogonal matrix Z is returned; *> = 'V': Z must contain an orthogonal matrix Z1 on entry, *> and the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI mark the rows and columns of A which are to be *> reduced. It is assumed that A is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are *> normally set by a previous call to SGGBAL; otherwise they *> should be set to 1 and N respectively. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA, N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, and the *> rest is set to zero. *> \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 N-by-N upper triangular matrix B. *> On exit, the upper triangular matrix T = Q**T B Z. The *> elements below the diagonal are set to zero. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the orthogonal matrix Q1, *> typically from the QR factorization of B. *> On exit, if COMPQ='I', the orthogonal matrix Q, and if *> COMPQ = 'V', the product Q1*Q. *> Not referenced if COMPQ='N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the orthogonal matrix Z1. *> On exit, if COMPZ='I', the orthogonal matrix Z, and if *> COMPZ = 'V', the product Z1*Z. *> Not referenced if COMPZ='N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. *> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. *> \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 realOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine reduces A to Hessenberg and B to triangular form by *> an unblocked reduction, as described in _Matrix_Computations_, *> by Golub and Van Loan (Johns Hopkins Press.) *> \endverbatim *> * ===================================================================== SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, 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 COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL ILQ, ILZ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW REAL C, S, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLARTG, SLASET, SROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode COMPQ * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * * Decode COMPZ * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Test the input parameters. * INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGHRD', -INFO ) RETURN END IF * * Initialize Q and Z if desired. * IF( ICOMPQ.EQ.3 ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Zero out lower triangle of B * DO 20 JCOL = 1, N - 1 DO 10 JROW = JCOL + 1, N B( JROW, JCOL ) = ZERO 10 CONTINUE 20 CONTINUE * * Reduce A and B * DO 40 JCOL = ILO, IHI - 2 * DO 30 JROW = IHI, JCOL + 2, -1 * * Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) * TEMP = A( JROW-1, JCOL ) CALL SLARTG( TEMP, A( JROW, JCOL ), C, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = ZERO CALL SROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, C, S ) CALL SROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, $ B( JROW, JROW-1 ), LDB, C, S ) IF( ILQ ) $ CALL SROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S ) * * Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) * TEMP = B( JROW, JROW ) CALL SLARTG( TEMP, B( JROW, JROW-1 ), C, S, $ B( JROW, JROW ) ) B( JROW, JROW-1 ) = ZERO CALL SROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) CALL SROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, $ S ) IF( ILZ ) $ CALL SROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) 30 CONTINUE 40 CONTINUE * RETURN * * End of SGGHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/shgeqz.f000066400000000000000000001302671522610125300262640ustar00rootroot00000000000000*> \brief \b SHGEQZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SHGEQZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * REAL ALPHAI( * ), ALPHAR( * ), BETA( * ), * $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SHGEQZ computes the eigenvalues of a real matrix pair (H,T), *> where H is an upper Hessenberg matrix and T is upper triangular, *> using the double-shift QZ method. *> Matrix pairs of this type are produced by the reduction to *> generalized upper Hessenberg form of a real matrix pair (A,B): *> *> A = Q1*H*Z1**T, B = Q1*T*Z1**T, *> *> as computed by SGGHRD. *> *> 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. *> *> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair *> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of *> eigenvalues. *> *> Additionally, the 2-by-2 upper triangular diagonal blocks of P *> corresponding to 2-by-2 blocks of S are reduced to positive diagonal *> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, *> P(j,j) > 0, and P(j+1,j+1) > 0. *> *> Optionally, the orthogonal matrix Q from the generalized Schur *> factorization may be postmultiplied into an input matrix Q1, and the *> orthogonal matrix Z may be postmultiplied into an input matrix Z1. *> If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced *> the matrix pair (A,B) to generalized upper Hessenberg form, then the *> output matrices Q1*Q and Z1*Z are the orthogonal factors from the *> 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. *> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the *> generalized nonsymmetric eigenvalue problem (GNEP) *> A*x = lambda*B*x *> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the *> alternate form of the GNEP *> mu*A*y = B*y. *> Real eigenvalues can be read directly from the generalized Schur *> form: *> alpha = S(i,i), beta = P(i,i). *> *> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix *> Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), *> pp. 241--256. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; *> = 'S': Compute eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': Left Schur vectors (Q) are not computed; *> = 'I': Q is initialized to the unit matrix and the matrix Q *> of left Schur vectors of (H,T) is returned; *> = 'V': Q must contain an orthogonal matrix Q1 on entry and *> the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Right Schur vectors (Z) are not computed; *> = 'I': Z is initialized to the unit matrix and the matrix Z *> of right Schur vectors of (H,T) is returned; *> = 'V': Z must contain an orthogonal matrix Z1 on entry and *> the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices H, T, Q, and Z. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI mark the rows and columns of H which are in *> Hessenberg form. It is assumed that A is already upper *> triangular in rows and columns 1:ILO-1 and IHI+1:N. *> If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH, N) *> On entry, the N-by-N upper Hessenberg matrix H. *> On exit, if JOB = 'S', H contains the upper quasi-triangular *> matrix S from the generalized Schur factorization. *> If JOB = 'E', the diagonal blocks of H match those of S, but *> the rest of H is unspecified. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max( 1, N ). *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is REAL array, dimension (LDT, N) *> On entry, the N-by-N upper triangular matrix T. *> On exit, if JOB = 'S', T contains the upper triangular *> matrix P from the generalized Schur factorization; *> 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S *> are reduced to positive diagonal form, i.e., if H(j+1,j) is *> non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and *> T(j+1,j+1) > 0. *> If JOB = 'E', the diagonal blocks of T match those of P, but *> the rest of T is unspecified. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max( 1, N ). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is REAL array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is REAL array, dimension (N) *> The imaginary parts of each scalar alpha defining an *> eigenvalue of GNEP. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). *> \endverbatim *> *> \param[out] BETA *> \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 *> mu = beta/alpha. Since either lambda or mu may overflow, *> they should not, in general, be computed. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in *> the reduction of (A,B) to generalized Hessenberg form. *> 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 COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If COMPQ='V' or 'I', then LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in *> the reduction of (A,B) to generalized Hessenberg form. *> On exit, if COMPZ = 'I', the orthogonal matrix of *> right Schur vectors of (H,T), and if COMPZ = 'V', the *> orthogonal matrix of right Schur vectors of (A,B). *> Not referenced if COMPZ = 'N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If COMPZ='V' or 'I', then LDZ >= 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 dimension of the array WORK. LWORK >= max(1,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 *> = 1,...,N: the QZ iteration did not converge. (H,T) is not *> in Schur form, but ALPHAR(i), ALPHAI(i), and *> BETA(i), i=INFO+1,...,N should be correct. *> = N+1,...,2*N: the shift calculation failed. (H,T) is not *> in Schur form, but ALPHAR(i), ALPHAI(i), and *> BETA(i), i=INFO-N+1,...,N should be correct. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> Iteration counters: *> *> JITER -- counts iterations. *> IITER -- counts iterations run since ILAST was last *> changed. This is therefore reset only when a 1-by-1 or *> 2-by-2 block deflates off the bottom. *> \endverbatim *> * ===================================================================== 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.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 COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. REAL ALPHAI( * ), ALPHAR( * ), BETA( * ), $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * $ SAFETY = 1.0E+0 ) REAL HALF, ZERO, ONE, SAFETY PARAMETER ( HALF = 0.5E+0, ZERO = 0.0E+0, ONE = 1.0E+0, $ SAFETY = 1.0E+2 ) * .. * .. Local Scalars .. LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, $ LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT REAL A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 * .. * .. Local Arrays .. REAL V( 3 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH, SLANHS, SLAPY2, SLAPY3 EXTERNAL LSAME, SLAMCH, SLANHS, SLAPY2, SLAPY3 * .. * .. External Subroutines .. EXTERNAL SLAG2, SLARFG, SLARTG, SLASET, SLASV2, SROT, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT * .. * .. Executable Statements .. * * Decode JOB, COMPQ, COMPZ * IF( LSAME( JOB, 'E' ) ) THEN ILSCHR = .FALSE. ISCHUR = 1 ELSE IF( LSAME( JOB, 'S' ) ) THEN ILSCHR = .TRUE. ISCHUR = 2 ELSE ISCHUR = 0 END IF * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Check Argument Values * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.EQ.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 ) THEN INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE IF( LDH.LT.N ) THEN INFO = -8 ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -17 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SHGEQZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = REAL( 1 ) RETURN END IF * * Initialize Q and Z * IF( ICOMPQ.EQ.3 ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Machine Constants * IN = IHI + 1 - ILO SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) BNORM = SLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) BSCALE = ONE / MAX( SAFMIN, BNORM ) * * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J H( JR, J ) = -H( JR, J ) T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE H( J, J ) = -H( J, J ) T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N Z( JR, J ) = -Z( JR, J ) 20 CONTINUE END IF END IF ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps * IF( IHI.LT.ILO ) $ GO TO 380 * * MAIN QZ ITERATION LOOP * * Initialize dynamic indices * * Eigenvalues ILAST+1:N have been found. * Column operations modify rows IFRSTM:whatever. * Row operations modify columns whatever:ILASTM. * * If only eigenvalues are being computed, then * IFRSTM is the row of the last splitting row above row ILAST; * this is always at least ILO. * IITER counts iterations since the last eigenvalue was found, * to tell when to use an extraordinary shift. * MAXIT is the maximum number of QZ sweeps allowed. * ILAST = IHI IF( ILSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ESHIFT = ZERO MAXIT = 30*( IHI-ILO+1 ) * DO 360 JITER = 1, MAXIT * * Split the matrix if possible. * * Two tests: * 1: H(j,j-1)=0 or j=ILO * 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * * Special case: j=ILAST * GO TO 80 ELSE IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN T( ILAST, ILAST ) = ZERO GO TO 70 END IF * * General case: j unfl ) * __ * (sA - wB) ( CZ -SZ ) * ( SZ CZ ) * C11R = S1*A11 - WR*B11 C11I = -WI*B11 C12 = S1*A12 C21 = S1*A21 C22R = S1*A22 - WR*B22 C22I = -WI*B22 * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN T1 = SLAPY3( C12, C11R, C11I ) CZ = C12 / T1 SZR = -C11R / T1 SZI = -C11I / T1 ELSE CZ = SLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN CZ = ZERO SZR = ONE SZI = ZERO ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ T1 = SLAPY2( CZ, C21 ) CZ = CZ / T1 SZR = -C21*TEMPR / T1 SZI = C21*TEMPI / T1 END IF END IF * * Compute Givens rotation on left * * ( CQ SQ ) * ( __ ) A or B * ( -SQ CQ ) * AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) BN = ABS( B11 ) + ABS( B22 ) WABS = ABS( WR ) + ABS( WI ) IF( S1*AN.GT.WABS*BN ) THEN CQ = CZ*B11 SQR = SZR*B22 SQI = -SZI*B22 ELSE A1R = CZ*A11 + SZR*A12 A1I = SZI*A12 A2R = CZ*A21 + SZR*A22 A2I = SZI*A22 CQ = SLAPY2( A1R, A1I ) IF( CQ.LE.SAFMIN ) THEN CQ = ZERO SQR = ONE SQI = ZERO ELSE TEMPR = A1R / CQ TEMPI = A1I / CQ SQR = TEMPR*A2R + TEMPI*A2I SQI = TEMPI*A2R - TEMPR*A2I END IF END IF T1 = SLAPY3( CQ, SQR, SQI ) CQ = CQ / T1 SQR = SQR / T1 SQI = SQI / T1 * * Compute diagonal elements of QBZ * TEMPR = SQR*SZR - SQI*SZI TEMPI = SQR*SZI + SQI*SZR B1R = CQ*CZ*B11 + TEMPR*B22 B1I = TEMPI*B22 B1A = SLAPY2( B1R, B1I ) B2R = CQ*CZ*B22 + TEMPR*B11 B2I = -TEMPI*B11 B2A = SLAPY2( B2R, B2I ) * * Normalize so beta > 0, and Im( alpha1 ) > 0 * BETA( ILAST-1 ) = B1A BETA( ILAST ) = B2A ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV ALPHAR( ILAST ) = ( WR*B2A )*S1INV ALPHAI( ILAST ) = -( WI*B2A )*S1INV * * Step 3: Go to next block -- exit if finished. * ILAST = IFIRST - 1 IF( ILAST.LT.ILO ) $ GO TO 380 * * Reset counters * IITER = 0 ESHIFT = ZERO IF( .NOT.ILSCHR ) THEN ILASTM = ILAST IF( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF GO TO 350 ELSE * * Usual case: 3x3 or larger block, using Francis implicit * double-shift * * 2 * Eigenvalue equation is w - c w + d = 0, * * -1 2 -1 * so compute 1st column of (A B ) - c A B + d * using the formula in QZIT (from EISPACK) * * We assume that the block is at least 3x3 * AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / $ ( BSCALE*T( ILAST, ILAST ) ) AD22 = ( ASCALE*H( ILAST, ILAST ) ) / $ ( BSCALE*T( ILAST, ILAST ) ) U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / $ ( BSCALE*T( IFIRST, IFIRST ) ) AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / $ ( BSCALE*T( IFIRST, IFIRST ) ) AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- $ ( AD22-AD11L )+AD21*U12 )*AD21L V( 3 ) = AD32L*AD21L * ISTART = IFIRST * CALL SLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE * * Sweep * DO 290 J = ISTART, ILAST - 2 * * All but last elements: use 3x3 Householder transforms. * * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN V( 1 ) = H( J, J-1 ) V( 2 ) = H( J+1, J-1 ) V( 3 ) = H( J+2, J-1 ) * CALL SLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE H( J+1, J-1 ) = ZERO H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* $ H( J+2, JC ) ) H( J, JC ) = H( J, JC ) - TEMP H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* $ T( J+2, JC ) ) T( J, JC ) = T( J, JC ) - TEMP2 T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* $ Q( JR, J+2 ) ) Q( JR, J ) = Q( JR, J ) - TEMP Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) 240 CONTINUE END IF * * Zero j-th column of B (see SLAGBC for details) * * Swap rows to pivot * ILPIVT = .FALSE. TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN W11 = T( J+1, J+1 ) W21 = T( J+2, J+1 ) W12 = T( J+1, J+2 ) W22 = T( J+2, J+2 ) U1 = T( J+1, J ) U2 = T( J+2, J ) ELSE W21 = T( J+1, J+1 ) W11 = T( J+2, J+1 ) W22 = T( J+1, J+2 ) W12 = T( J+2, J+2 ) U2 = T( J+1, J ) U1 = T( J+2, J ) END IF * * Swap columns if nec. * IF( ABS( W12 ).GT.ABS( W11 ) ) THEN ILPIVT = .TRUE. TEMP = W12 TEMP2 = W22 W12 = W11 W22 = W21 W11 = TEMP W21 = TEMP2 END IF * * LU-factor * TEMP = W21 / W11 U2 = U2 - TEMP*U1 W22 = W22 - TEMP*W12 W21 = ZERO * * Compute SCALE * SCALE = ONE IF( ABS( W22 ).LT.SAFMIN ) THEN SCALE = ZERO U2 = ONE U1 = -W12 / W11 GO TO 250 END IF IF( ABS( W22 ).LT.ABS( U2 ) ) $ SCALE = ABS( W22 / U2 ) IF( ABS( W11 ).LT.ABS( U1 ) ) $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) * * Solve * U2 = ( SCALE*U2 ) / W22 U1 = ( SCALE*U1-W12*U2 ) / W11 * 250 CONTINUE IF( ILPIVT ) THEN TEMP = U2 U2 = U1 U1 = TEMP END IF * * Compute Householder Vector * T1 = SQRT( SCALE**2+U1**2+U2**2 ) TAU = ONE + SCALE / T1 VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 * * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* $ H( JR, J+2 ) ) H( JR, J ) = H( JR, J ) - TEMP H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* $ T( JR, J+2 ) ) T( JR, J ) = T( JR, J ) - TEMP T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* $ Z( JR, J+2 ) ) Z( JR, J ) = Z( JR, J ) - TEMP Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF T( J+1, J ) = ZERO T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations * * Rotations from the left * J = ILAST - 1 TEMP = H( J, J-1 ) CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM TEMP = C*H( J, JC ) + S*H( J+1, JC ) H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) H( J, JC ) = TEMP TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) Q( JR, J ) = TEMP 310 CONTINUE END IF * * Rotations from the right. * TEMP = T( J+1, J+1 ) CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST TEMP = C*H( JR, J+1 ) + S*H( JR, J ) H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 TEMP = C*T( JR, J+1 ) + S*T( JR, J ) T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) Z( JR, J+1 ) = TEMP 340 CONTINUE END IF * * End of Double-Shift code * END IF * GO TO 350 * * End of iteration loop * 350 CONTINUE 360 CONTINUE * * Drop-through = non-convergence * INFO = ILAST GO TO 420 * * Successful completion of all QZ steps * 380 CONTINUE * * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J H( JR, J ) = -H( JR, J ) T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE H( J, J ) = -H( J, J ) T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N Z( JR, J ) = -Z( JR, J ) 400 CONTINUE END IF END IF ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination * INFO = 0 * * Exit (other than argument error) -- return optimal workspace size * 420 CONTINUE WORK( 1 ) = REAL( N ) RETURN * * End of SHGEQZ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/shseqr.f000066400000000000000000000443071522610125300262670ustar00rootroot00000000000000*> \brief \b SHSEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SHSEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SHSEQR computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**T, where T is an upper quasi-triangular matrix (the *> Schur form), and Z is the orthogonal matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input orthogonal *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': compute eigenvalues only; *> = 'S': compute eigenvalues and the Schur form T. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': no Schur vectors are computed; *> = 'I': Z is initialized to the unit matrix and the matrix Z *> of Schur vectors of H is returned; *> = 'V': Z must contain an orthogonal matrix Q on entry, and *> the product Q*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to SGEBAL, and then passed to ZGEHRD *> when the matrix output by SGEBAL is reduced to Hessenberg *> form. Otherwise ILO and IHI should be set to 1 and N *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and JOB = 'S', then H contains the *> upper quasi-triangular matrix T from the Schur decomposition *> (the Schur form); 2-by-2 diagonal blocks (corresponding to *> complex conjugate pairs of eigenvalues) are returned in *> standard form, with H(i,i) = H(i+1,i+1) and *> H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the *> contents of H are unspecified on exit. (The output value of *> H when INFO.GT.0 is given under the description of INFO *> below.) *> *> Unlike earlier versions of SHSEQR, this subroutine may *> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 *> or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is REAL array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL array, dimension (N) *> *> The real and imaginary parts, respectively, of the computed *> eigenvalues. If two eigenvalues are computed as a complex *> conjugate pair, they are stored in consecutive elements of *> WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and *> WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in *> the same order as on the diagonal of the Schur form returned *> in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 *> diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and *> WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,N) *> If COMPZ = 'N', Z is not referenced. *> If COMPZ = 'I', on entry Z need not be set and on exit, *> if INFO = 0, Z contains the orthogonal matrix Z of the Schur *> vectors of H. If COMPZ = 'V', on entry Z must contain an *> N-by-N matrix Q, which is assumed to be equal to the unit *> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, *> if INFO = 0, Z contains Q*Z. *> Normally Q is the orthogonal matrix generated by SORGHR *> after the call to SGEHRD which formed the Hessenberg matrix *> H. (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if COMPZ = 'I' or *> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient and delivers very good and sometimes *> optimal performance. However, LWORK as large as 11*N *> may be required for optimal performance. A workspace *> query is recommended to determine the optimal workspace *> size. *> *> If LWORK = -1, then SHSEQR does a workspace query. *> In this case, SHSEQR checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .LT. 0: if INFO = -i, the i-th argument had an illegal *> value *> .GT. 0: if INFO = i, SHSEQR failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and JOB = 'E', then on exit, the *> remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and JOB = 'S', then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is an orthogonal matrix. The final *> value of H is upper Hessenberg and quasi-triangular *> in rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and COMPZ = 'V', then on exit *> *> (final value of Z) = (initial value of Z)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'I', then on exit *> (final value of Z) = U *> where U is the orthogonal matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'N', then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERcomputational * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> Default values supplied by *> ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). *> It is suggested that these defaults be adjusted in order *> to attain best performance in each particular *> computational environment. *> *> ISPEC=12: The SLAHQR vs SLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> ISPEC=13: Recommended deflation window size. *> This depends on ILO, IHI and NS. NS is the *> number of simultaneous shifts returned *> by ILAENV(ISPEC=15). (See ISPEC=15 below.) *> The default for (IHI-ILO+1).LE.500 is NS. *> The default for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> ISPEC=14: Nibble crossover point. (See IPARMQ for *> details.) Default: 14% of deflation window *> size. *> *> ISPEC=15: Number of simultaneous shifts in a multishift *> QR iteration. *> *> If IHI-ILO+1 is ... *> *> greater than ...but less ... the *> or equal to ... than default is *> *> 1 30 NS = 2(+) *> 30 60 NS = 4(+) *> 60 150 NS = 10(+) *> 150 590 NS = ** *> 590 3000 NS = 64 *> 3000 6000 NS = 128 *> 6000 infinity NS = 256 *> *> (+) By default some or all matrices of this order *> are passed to the implicit double shift routine *> SLAHQR and this parameter is ignored. See *> ISPEC=12 above and comments in IPARMQ for *> details. *> *> (**) The asterisks (**) indicate an ad-hoc *> function of N increasing from 10 to 64. *> *> ISPEC=16: Select structured matrix multiply. *> If the number of simultaneous shifts (specified *> by ISPEC=15) is less than 14, then the default *> for ISPEC=16 is 0. Otherwise the default for *> ISPEC=16 is 2. *> \endverbatim * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. * * ===================================================================== SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, 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 IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . SLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare SLAHQR failure. NL .GT. NTINY = 11 is * . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== INTEGER NL PARAMETER ( NL = 49 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Arrays .. REAL HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. INTEGER I, KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. INTEGER ILAENV LOGICAL LSAME EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL SLACPY, SLAHQR, SLAQR0, SLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL * .. * .. Executable Statements .. * * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) WORK( 1 ) = REAL( MAX( 1, N ) ) LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.NE.0 ) THEN * * ==== Quick return in case of invalid argument. ==== * CALL XERBLA( 'SHSEQR', -INFO ) RETURN * ELSE IF( N.EQ.0 ) THEN * * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ELSE IF( LQUERY ) THEN * * ==== Quick return in case of a workspace query ==== * CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, WORK, LWORK, INFO ) * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) ) RETURN * ELSE * * ==== copy eigenvalues isolated by SGEBAL ==== * DO 10 I = 1, ILO - 1 WR( I ) = H( I, I ) WI( I ) = ZERO 10 CONTINUE DO 20 I = IHI + 1, N WR( I ) = H( I, I ) WI( I ) = ZERO 20 CONTINUE * * ==== Initialize Z, if requested ==== * IF( INITZ ) $ CALL SLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * * ==== Quick return if possible ==== * IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * ==== SLAHQR/SLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== SLAQR0 for big matrices; SLAHQR for small ones ==== * IF( N.GT.NMIN ) THEN CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, WORK, LWORK, INFO ) ELSE * * ==== Small matrix ==== * CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, INFO ) * IF( INFO.GT.0 ) THEN * * ==== A rare SLAHQR failure! SLAQR0 sometimes succeeds * . when SLAHQR fails. ==== * KBOT = INFO * IF( N.GE.NL ) THEN * * ==== Larger matrices have enough subdiagonal scratch * . space to call SLAQR0 directly. ==== * CALL SLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ELSE * * ==== Tiny matrices don't have enough subdiagonal * . scratch space to benefit from SLAQR0. Hence, * . tiny matrices must be copied into a larger * . array before calling SLAQR0. ==== * CALL SLACPY( 'A', N, N, H, LDH, HL, NL ) HL( N+1, N ) = ZERO CALL SLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), $ NL ) CALL SLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) IF( WANTT .OR. INFO.NE.0 ) $ CALL SLACPY( 'A', N, N, HL, NL, H, LDH ) END IF END IF END IF * * ==== Clear out the trash, if necessary. ==== * IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) $ CALL SLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== * WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) ) END IF * * ==== End of SHSEQR ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sisnan.f000066400000000000000000000036711522610125300262540ustar00rootroot00000000000000*> \brief \b SISNAN tests input for NaN. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SISNAN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION SISNAN( SIN ) * * .. Scalar Arguments .. * REAL SIN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SISNAN returns .TRUE. if its argument is NaN, and .FALSE. *> otherwise. To be replaced by the Fortran 2003 intrinsic in the *> future. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIN *> \verbatim *> SIN is REAL *> Input to test for NaN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION SISNAN( SIN ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL SIN * .. * * ===================================================================== * * .. External Functions .. LOGICAL SLAISNAN EXTERNAL SLAISNAN * .. * .. Executable Statements .. SISNAN = SLAISNAN(SIN,SIN) RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slabad.f000066400000000000000000000057631522610125300262130ustar00rootroot00000000000000*> \brief \b SLABAD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLABAD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLABAD( SMALL, LARGE ) * * .. Scalar Arguments .. * REAL LARGE, SMALL * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLABAD takes as input the values computed by SLAMCH for underflow and *> overflow, and returns the square root of each of these values if the *> log of LARGE is sufficiently large. This subroutine is intended to *> identify machines with a large exponent range, such as the Crays, and *> redefine the underflow and overflow limits to be the square roots of *> the values computed by SLAMCH. This subroutine is needed because *> SLAMCH does not compensate for poor arithmetic in the upper half of *> the exponent range, as is found on a Cray. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] SMALL *> \verbatim *> SMALL is REAL *> On entry, the underflow threshold as computed by SLAMCH. *> On exit, if LOG10(LARGE) is sufficiently large, the square *> root of SMALL, otherwise unchanged. *> \endverbatim *> *> \param[in,out] LARGE *> \verbatim *> LARGE is REAL *> On entry, the overflow threshold as computed by SLAMCH. *> On exit, if LOG10(LARGE) is sufficiently large, the square *> root of LARGE, otherwise unchanged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL LARGE, SMALL * .. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000. ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of SLABAD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slabrd.f000066400000000000000000000327151522610125300262310ustar00rootroot00000000000000*> \brief \b SLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLABRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLABRD reduces the first NB rows and columns of a real general *> m by n matrix A to upper or lower bidiagonal form by an orthogonal *> transformation Q**T * A * P, and returns the matrices X and Y which *> are needed to apply the transformation to the unreduced part of A. *> *> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower *> bidiagonal form. *> *> This is an auxiliary routine called by SGEBRD *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of leading rows and columns of A to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, the first NB rows and columns of the matrix are *> overwritten; the rest of the array is unchanged. *> If m >= n, elements on and below the diagonal in the first NB *> columns, with the array TAUQ, represent the orthogonal *> matrix Q as a product of elementary reflectors; and *> elements above the diagonal in the first NB rows, with the *> array TAUP, represent the orthogonal matrix P as a product *> of elementary reflectors. *> If m < n, elements below the diagonal in the first NB *> columns, with the array TAUQ, represent the orthogonal *> matrix Q as a product of elementary reflectors, and *> elements on and above the diagonal in the first NB rows, *> with the array TAUP, represent the orthogonal matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is REAL array, dimension (NB) *> The diagonal elements of the first NB rows and columns of *> the reduced matrix. D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is REAL array, dimension (NB) *> The off-diagonal elements of the first NB rows and columns of *> the reduced matrix. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is REAL array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is REAL array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is REAL array, dimension (LDX,NB) *> The m-by-nb matrix X required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,M). *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is REAL array, dimension (LDY,NB) *> The n-by-nb matrix Y required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors. *> *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in *> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The elements of the vectors v and u together form the m-by-nb matrix *> V and the nb-by-n matrix U**T which are needed, with X and Y, to apply *> the transformation to the unreduced part of the matrix, using a block *> update of the form: A := A - V*Y**T - X*U**T. *> *> The contents of A on exit are illustrated by the following examples *> with nb = 2: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) *> ( v1 v2 a a a ) ( v1 1 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix which is unchanged, *> vi denotes an element of the vector defining H(i), and ui an element *> of the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL SGEMV, SLARFG, SSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL SGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) CALL SGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+1:m,i) * CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) IF( I.LT.N ) THEN A( I, I ) = ONE * * Compute Y(i+1:n,i) * CALL SGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL SGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) * * Generate reflection P(i) to annihilate A(i,i+2:n) * CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) A( I, I+1 ) = ONE * * Compute X(i+1:m,i) * CALL SGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) CALL SGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL SGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) CALL SGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) * * Generate reflection P(i) to annihilate A(i,i+1:n) * CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = A( I, I ) IF( I.LT.M ) THEN A( I, I ) = ONE * * Compute X(i+1:m,i) * CALL SGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL SGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL SGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) * * Update A(i+1:m,i) * CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) CALL SGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+2:m,i) * CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Compute Y(i+1:n,i) * CALL SGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) CALL SGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL SGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) CALL SGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) END IF 20 CONTINUE END IF RETURN * * End of SLABRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slacn2.f000066400000000000000000000167751522610125300261540ustar00rootroot00000000000000*> \brief \b SLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLACN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST * .. * .. Array Arguments .. * INTEGER ISGN( * ), ISAVE( 3 ) * REAL V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLACN2 estimates the 1-norm of a square, real matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is REAL array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is REAL array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**T * X, if KASE=2, *> and SLACN2 must be re-called with all the other parameters *> unchanged. *> \endverbatim *> *> \param[out] ISGN *> \verbatim *> ISGN is INTEGER array, dimension (N) *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to SLACN2, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**T * X. *> On the final return from SLACN2, KASE will again be 0. *> \endverbatim *> *> \param[in,out] ISAVE *> \verbatim *> ISAVE is INTEGER array, dimension (3) *> ISAVE is used to save variables between calls to SLACN2 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Originally named SONEST, dated March 16, 1988. *> *> This is a thread safe version of SLACON, which uses the array ISAVE *> in place of a SAVE statement, as follows: *> *> SLACON SLACN2 *> JUMP ISAVE(1) *> J ISAVE(2) *> ITER ISAVE(3) *> \endverbatim * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N REAL EST * .. * .. Array Arguments .. INTEGER ISGN( * ), ISAVE( 3 ) REAL V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. INTEGER I, JLAST REAL ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER ISAMAX REAL SASUM EXTERNAL ISAMAX, SASUM * .. * .. External Subroutines .. EXTERNAL SCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, NINT, REAL, SIGN * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / REAL( N ) 10 CONTINUE KASE = 1 ISAVE( 1 ) = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) * * ................ ENTRY (ISAVE( 1 ) = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = SASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 ISAVE( 1 ) = 2 RETURN * * ................ ENTRY (ISAVE( 1 ) = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE ISAVE( 2 ) = ISAMAX( N, X, 1 ) ISAVE( 3 ) = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( ISAVE( 2 ) ) = ONE KASE = 1 ISAVE( 1 ) = 3 RETURN * * ................ ENTRY (ISAVE( 1 ) = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL SCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = SASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 ISAVE( 1 ) = 4 RETURN * * ................ ENTRY (ISAVE( 1 ) = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = ISAVE( 2 ) ISAVE( 2 ) = ISAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN ISAVE( 3 ) = ISAVE( 3 ) + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 ISAVE( 1 ) = 5 RETURN * * ................ ENTRY (ISAVE( 1 ) = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL SCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of SLACN2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slacon.f000066400000000000000000000156321522610125300262400ustar00rootroot00000000000000*> \brief \b SLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLACON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) * * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST * .. * .. Array Arguments .. * INTEGER ISGN( * ) * REAL V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLACON estimates the 1-norm of a square, real matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is REAL array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is REAL array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**T * X, if KASE=2, *> and SLACON must be re-called with all the other parameters *> unchanged. *> \endverbatim *> *> \param[out] ISGN *> \verbatim *> ISGN is INTEGER array, dimension (N) *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to SLACON, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**T * X. *> On the final return from SLACON, KASE will again be 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester. \n *> Originally named SONEST, dated March 16, 1988. * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N REAL EST * .. * .. Array Arguments .. INTEGER ISGN( * ) REAL V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER ISAMAX REAL SASUM EXTERNAL ISAMAX, SASUM * .. * .. External Subroutines .. EXTERNAL SCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, NINT, REAL, SIGN * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / REAL( N ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = SASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE J = ISAMAX( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( J ) = ONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL SCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = SASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = J J = ISAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL SCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of SLACON * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slacpy.f000066400000000000000000000077511522610125300262570ustar00rootroot00000000000000*> \brief \b SLACPY copies all or part of one two-dimensional array to another. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLACPY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLACPY copies all or part of a two-dimensional matrix A to another *> matrix B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be copied to B. *> = 'U': Upper triangular part *> = 'L': Lower triangular part *> Otherwise: All of the matrix A *> \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] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> The m by n matrix A. If UPLO = 'U', only the upper triangle *> or trapezoid is accessed; if UPLO = 'L', only the lower *> triangle or trapezoid is accessed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] B *> \verbatim *> B is REAL array, dimension (LDB,N) *> On exit, B = A in the locations specified by UPLO. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.7.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, LDB, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN * * End of SLACPY * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sladiv.f000066400000000000000000000135521522610125300262420ustar00rootroot00000000000000*> \brief \b SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLADIV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLADIV( A, B, C, D, P, Q ) * * .. Scalar Arguments .. * REAL A, B, C, D, P, Q * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLADIV performs complex division in real arithmetic *> *> a + i*b *> p + i*q = --------- *> c + i*d *> *> The algorithm is due to Michael Baudin and Robert L. Smith *> and can be found in the paper *> "A Robust Complex Division in Scilab" *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is REAL *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL *> \endverbatim *> *> \param[in] C *> \verbatim *> C is REAL *> \endverbatim *> *> \param[in] D *> \verbatim *> D is REAL *> The scalars a, b, c, and d in the above expression. *> \endverbatim *> *> \param[out] P *> \verbatim *> P is REAL *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is REAL *> The scalars p and q in the above expression. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date January 2013 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. REAL A, B, C, D, P, Q * .. * * ===================================================================== * * .. Parameters .. REAL BS PARAMETER ( BS = 2.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) * * .. Local Scalars .. REAL AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL SLADIV1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * AA = A BB = B CC = C DD = D 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 S = TWO * S END IF IF( CD >= HALF*OV ) THEN CC = HALF * CC DD = HALF * DD S = HALF * S END IF IF( AB <= UN*BS/EPS ) THEN AA = AA * BE BB = BB * BE S = S / BE END IF IF( CD <= UN*BS/EPS ) THEN CC = CC * BE DD = DD * BE S = S * BE END IF IF( ABS( D ).LE.ABS( C ) ) THEN CALL SLADIV1(AA, BB, CC, DD, P, Q) ELSE CALL SLADIV1(BB, AA, DD, CC, P, Q) Q = -Q END IF P = P * S Q = Q * S * RETURN * * End of SLADIV * END *> \ingroup realOTHERauxiliary SUBROUTINE SLADIV1( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. REAL A, B, C, D, P, Q * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) * * .. Local Scalars .. REAL R, T * .. * .. External Functions .. REAL SLADIV2 EXTERNAL SLADIV2 * .. * .. Executable Statements .. * R = D / C T = ONE / (C + D * R) P = SLADIV2(A, B, C, D, R, T) A = -A Q = SLADIV2(B, A, C, D, R, T) * RETURN * * End of SLADIV1 * END *> \ingroup realOTHERauxiliary REAL FUNCTION SLADIV2( A, B, C, D, R, T ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. REAL A, B, C, D, R, T * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) * * .. Local Scalars .. REAL BR * .. * .. Executable Statements .. * IF( R.NE.ZERO ) THEN BR = B * R if( BR.NE.ZERO ) THEN SLADIV2 = (A + BR) * T ELSE SLADIV2 = A * T + (B * T) * R END IF ELSE SLADIV2 = (A + D * (B / C)) * T END IF * RETURN * * End of SLADIV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slae2.f000066400000000000000000000112151522610125300257600ustar00rootroot00000000000000*> \brief \b SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAE2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) * * .. Scalar Arguments .. * REAL A, B, C, RT1, RT2 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix *> [ A B ] *> [ B C ]. *> On return, RT1 is the eigenvalue of larger absolute value, and RT2 *> is the eigenvalue of smaller absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is REAL *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL *> The (1,2) and (2,1) elements of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is REAL *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is REAL *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is REAL *> The eigenvalue of smaller absolute value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL A, B, C, RT1, RT2 * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) * .. * .. Local Scalars .. REAL AB, ACMN, ACMX, ADF, DF, RT, SM, TB * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN * * End of SLAE2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaev2.f000066400000000000000000000137461522610125300261610ustar00rootroot00000000000000*> \brief \b SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAEV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * .. Scalar Arguments .. * REAL A, B, C, CS1, RT1, RT2, SN1 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix *> [ A B ] *> [ B C ]. *> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the *> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right *> eigenvector for RT1, giving the decomposition *> *> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] *> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is REAL *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL *> The (1,2) element and the conjugate of the (2,1) element of *> the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is REAL *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is REAL *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is REAL *> The eigenvalue of smaller absolute value. *> \endverbatim *> *> \param[out] CS1 *> \verbatim *> CS1 is REAL *> \endverbatim *> *> \param[out] SN1 *> \verbatim *> SN1 is REAL *> The vector (CS1, SN1) is a unit right eigenvector for RT1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> CS1 and SN1 are accurate to a few ulps barring over/underflow. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL A, B, C, CS1, RT1, RT2, SN1 * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) * .. * .. Local Scalars .. INTEGER SGN1, SGN2 REAL AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF * * Compute the eigenvector * IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN * * End of SLAEV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaexc.f000066400000000000000000000307111522610125300262330ustar00rootroot00000000000000*> \brief \b SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in *> an upper quasi-triangular matrix T by an orthogonal similarity *> transformation. *> *> T must be in Schur canonical form, that is, block upper triangular *> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block *> has its diagonal elemnts equal and its off-diagonal elements of *> opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> = .TRUE. : accumulate the transformation in the matrix Q; *> = .FALSE.: do not accumulate the transformation. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is REAL array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> canonical form. *> On exit, the updated matrix T, again 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] Q *> \verbatim *> Q is REAL array, dimension (LDQ,N) *> On entry, if WANTQ is .TRUE., the orthogonal matrix Q. *> On exit, if WANTQ is .TRUE., the updated matrix Q. *> If WANTQ is .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index of the first row of the first block T11. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The order of the first block T11. N1 = 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> The order of the second block T22. N2 = 0, 1 or 2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> = 1: the transformed matrix T would be too far from Schur *> form; the blocks are not swapped and T and Q are *> unchanged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 WANTQ INTEGER INFO, J1, LDQ, LDT, N, N1, N2 * .. * .. Array Arguments .. REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL TEN PARAMETER ( TEN = 1.0E+1 ) INTEGER LDD, LDX PARAMETER ( LDD = 4, LDX = 2 ) * .. * .. Local Scalars .. INTEGER IERR, J2, J3, J4, K, ND REAL CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, $ WR1, WR2, XNORM * .. * .. Local Arrays .. REAL D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), $ X( LDX, 2 ) * .. * .. External Functions .. REAL SLAMCH, SLANGE EXTERNAL SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SLACPY, SLANV2, SLARFG, SLARFX, SLARTG, SLASY2, $ SROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN IF( J1+N1.GT.N ) $ RETURN * J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 * IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * T11 = T( J1, J1 ) T22 = T( J2, J2 ) * * Determine the transformation to perform the interchange. * CALL SLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( J3.LE.N ) $ CALL SROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, $ SN ) CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) * T( J1, J1 ) = T22 T( J2, J2 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * ELSE * * Swapping involves at least one 2-by-2 block. * * Copy the diagonal block of order N1+N2 to the local array D * and compute its norm. * ND = N1 + N2 CALL SLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) DNORM = SLANGE( 'Max', ND, ND, D, LDD, WORK ) * * Compute machine-dependent threshold for test for accepting * swap. * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) * * Solve T11*X - X*T22 = scale*T12 for X. * CALL SLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, $ LDX, XNORM, IERR ) * * Swap the adjacent diagonal blocks. * K = N1 + N1 + N2 - 3 GO TO ( 10, 20, 30 )K * 10 CONTINUE * * N1 = 1, N2 = 2: generate elementary reflector H so that: * * ( scale, X11, X12 ) H = ( 0, 0, * ) * U( 1 ) = SCALE U( 2 ) = X( 1, 1 ) U( 3 ) = X( 1, 2 ) CALL SLARFG( 3, U( 3 ), U, 1, TAU ) U( 3 ) = ONE T11 = T( J1, J1 ) * * Perform swap provisionally on diagonal block in D. * CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, $ 3 )-T11 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL SLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) CALL SLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J3, J3 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 20 CONTINUE * * N1 = 2, N2 = 1: generate elementary reflector H so that: * * H ( -X11 ) = ( * ) * ( -X21 ) = ( 0 ) * ( scale ) = ( 0 ) * U( 1 ) = -X( 1, 1 ) U( 2 ) = -X( 2, 1 ) U( 3 ) = SCALE CALL SLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) U( 1 ) = ONE T33 = T( J3, J3 ) * * Perform swap provisionally on diagonal block in D. * CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, $ 1 )-T33 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL SLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) CALL SLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) * T( J1, J1 ) = T33 T( J2, J1 ) = ZERO T( J3, J1 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 30 CONTINUE * * N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so * that: * * H(2) H(1) ( -X11 -X12 ) = ( * * ) * ( -X21 -X22 ) ( 0 * ) * ( scale 0 ) ( 0 0 ) * ( 0 scale ) ( 0 0 ) * U1( 1 ) = -X( 1, 1 ) U1( 2 ) = -X( 2, 1 ) U1( 3 ) = SCALE CALL SLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) U1( 1 ) = ONE * TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) U2( 2 ) = -TEMP*U1( 3 ) U2( 3 ) = SCALE CALL SLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) U2( 1 ) = ONE * * Perform swap provisionally on diagonal block in D. * CALL SLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) CALL SLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) CALL SLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) CALL SLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL SLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) CALL SLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) CALL SLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) CALL SLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J4, J1 ) = ZERO T( J4, J2 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) CALL SLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) END IF * 40 CONTINUE * IF( N2.EQ.2 ) THEN * * Standardize new 2-by-2 block T11 * CALL SLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, $ CS, SN ) CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) IF( WANTQ ) $ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * IF( N1.EQ.2 ) THEN * * Standardize new 2-by-2 block T22 * J3 = J1 + N2 J4 = J3 + 1 CALL SLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) IF( J3+2.LE.N ) $ CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), $ LDT, CS, SN ) CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) IF( WANTQ ) $ CALL SROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) END IF * END IF RETURN * * Exit with INFO = 1 if swap was rejected. * 50 INFO = 1 RETURN * * End of SLAEXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slag2.f000066400000000000000000000300571522610125300257670ustar00rootroot00000000000000*> \brief \b SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAG2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue *> problem A - w B, with scaling as necessary to avoid over-/underflow. *> *> The scaling factor "s" results in a modified eigenvalue equation *> *> s A - w B *> *> where s is a non-negative scaling factor chosen so that w, w B, *> and s A do not overflow and, if possible, do not underflow, either. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA, 2) *> On entry, the 2 x 2 matrix A. It is assumed that its 1-norm *> is less than 1/SAFMIN. Entries less than *> sqrt(SAFMIN)*norm(A) are subject to being treated as zero. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 2. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB, 2) *> On entry, the 2 x 2 upper triangular matrix B. It is *> assumed that the one-norm of B is less than 1/SAFMIN. The *> diagonals should be at least sqrt(SAFMIN) times the largest *> element of B (in absolute value); if a diagonal is smaller *> than that, then +/- sqrt(SAFMIN) will be used instead of *> that diagonal. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= 2. *> \endverbatim *> *> \param[in] SAFMIN *> \verbatim *> SAFMIN is REAL *> The smallest positive number s.t. 1/SAFMIN does not *> overflow. (This should always be SLAMCH('S') -- it is an *> argument in order to avoid having to call SLAMCH frequently.) *> \endverbatim *> *> \param[out] SCALE1 *> \verbatim *> SCALE1 is REAL *> A scaling factor used to avoid over-/underflow in the *> eigenvalue equation which defines the first eigenvalue. If *> the eigenvalues are complex, then the eigenvalues are *> ( WR1 +/- WI i ) / SCALE1 (which may lie outside the *> exponent range of the machine), SCALE1=SCALE2, and SCALE1 *> 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 threshold if the exact eigenvalue *> is sufficiently large. *> \endverbatim *> *> \param[out] SCALE2 *> \verbatim *> SCALE2 is REAL *> A scaling factor used to avoid over-/underflow in the *> eigenvalue equation which defines the second eigenvalue. If *> the eigenvalues are complex, then SCALE2=SCALE1. If the *> 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 *> threshold if the exact eigenvalue is sufficiently large. *> \endverbatim *> *> \param[out] WR1 *> \verbatim *> WR1 is REAL *> If the eigenvalue is real, then WR1 is SCALE1 times the *> eigenvalue closest to the (2,2) element of A B**(-1). If the *> eigenvalue is complex, then WR1=WR2 is SCALE1 times the real *> part of the eigenvalues. *> \endverbatim *> *> \param[out] WR2 *> \verbatim *> WR2 is REAL *> If the eigenvalue is real, then WR2 is SCALE2 times the *> other eigenvalue. If the eigenvalue is complex, then *> WR1=WR2 is SCALE1 times the real part of the eigenvalues. *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL *> If the eigenvalue is real, then WI is zero. If the *> eigenvalue is complex, then WI is SCALE1 times the imaginary *> part of the eigenvalues. WI will always be non-negative. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER LDA, LDB REAL SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) REAL HALF PARAMETER ( HALF = ONE / TWO ) REAL FUZZY1 PARAMETER ( FUZZY1 = ONE+1.0E-5 ) * .. * .. Local Scalars .. REAL A11, A12, A21, A22, ABI22, ANORM, AS11, AS12, $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22, $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5, $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2, $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET, $ WSCALE, WSIZE, WSMALL * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * RTMIN = SQRT( SAFMIN ) RTMAX = ONE / RTMIN SAFMAX = ONE / SAFMIN * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A11 = ASCALE*A( 1, 1 ) A21 = ASCALE*A( 2, 1 ) A12 = ASCALE*A( 1, 2 ) A22 = ASCALE*A( 2, 2 ) * * Perturb B if necessary to insure non-singularity * B11 = B( 1, 1 ) B12 = B( 1, 2 ) B22 = B( 2, 2 ) BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN ) IF( ABS( B11 ).LT.BMIN ) $ B11 = SIGN( BMIN, B11 ) IF( ABS( B22 ).LT.BMIN ) $ B22 = SIGN( BMIN, B22 ) * * Scale B * BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN ) BSIZE = MAX( ABS( B11 ), ABS( B22 ) ) BSCALE = ONE / BSIZE B11 = B11*BSCALE B12 = B12*BSCALE B22 = B22*BSCALE * * Compute larger eigenvalue by method described by C. van Loan * * ( AS is A shifted by -SHIFT*B ) * BINV11 = ONE / B11 BINV22 = ONE / B22 S1 = A11*BINV11 S2 = A22*BINV22 IF( ABS( S1 ).LE.ABS( S2 ) ) THEN AS12 = A12 - S1*B12 AS22 = A22 - S1*B22 SS = A21*( BINV11*BINV22 ) ABI22 = AS22*BINV22 - SS*B12 PP = HALF*ABI22 SHIFT = S1 ELSE AS12 = A12 - S2*B12 AS11 = A11 - S2*B11 SS = A21*( BINV11*BINV22 ) ABI22 = -SS*B12 PP = HALF*( AS11*BINV11+ABI22 ) SHIFT = S2 END IF QQ = SS*AS12 IF( ABS( PP*RTMIN ).GE.ONE ) THEN DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN R = SQRT( ABS( DISCR ) )*RTMAX ELSE IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX R = SQRT( ABS( DISCR ) )*RTMIN ELSE DISCR = PP**2 + QQ R = SQRT( ABS( DISCR ) ) END IF END IF * * 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 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 = PP - SIGN( R, PP ) WBIG = SHIFT + SUM * * Compute smaller eigenvalue * WSMALL = SHIFT + DIFF IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 ) WSMALL = WDET / WBIG END IF * * Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) * for WR1. * IF( PP.GT.ABI22 ) THEN WR1 = MIN( WBIG, WSMALL ) WR2 = MAX( WBIG, WSMALL ) ELSE WR1 = MAX( WBIG, WSMALL ) WR2 = MIN( WBIG, WSMALL ) END IF WI = ZERO ELSE * * Complex eigenvalues * WR1 = SHIFT + PP WR2 = WR1 WI = R END IF * * Further scaling to avoid underflow and overflow in computing * SCALE1 and overflow in computing w*B. * * This scale factor (WSCALE) is bounded from above using C1 and C2, * and from below using C3 and C4. * C1 implements the condition s A must never overflow. * C2 implements the condition w B must never overflow. * C3, with C2, * implement the condition that s A - w B must never overflow. * C4 implements the condition s should not underflow. * C5 implements the condition max(s,|w|) should be at least 2. * C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) ) C2 = SAFMIN*MAX( ONE, BNORM ) C3 = BSIZE*SAFMIN IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE ) ELSE C4 = ONE END IF IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN C5 = MIN( ONE, ASCALE*BSIZE ) ELSE C5 = ONE END IF * * Scale first eigenvalue * WABS = ABS( WR1 ) + ABS( WI ) WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ), $ MIN( C4, HALF*MAX( WABS, C5 ) ) ) IF( WSIZE.NE.ONE ) THEN WSCALE = ONE / WSIZE IF( WSIZE.GT.ONE ) THEN SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )* $ MIN( ASCALE, BSIZE ) ELSE SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )* $ MAX( ASCALE, BSIZE ) END IF WR1 = WR1*WSCALE IF( WI.NE.ZERO ) THEN WI = WI*WSCALE WR2 = WR1 SCALE2 = SCALE1 END IF ELSE SCALE1 = ASCALE*BSIZE SCALE2 = SCALE1 END IF * * Scale second eigenvalue (if real) * IF( WI.EQ.ZERO ) THEN WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ), $ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) ) IF( WSIZE.NE.ONE ) THEN WSCALE = ONE / WSIZE IF( WSIZE.GT.ONE ) THEN SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )* $ MIN( ASCALE, BSIZE ) ELSE SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )* $ MAX( ASCALE, BSIZE ) END IF WR2 = WR2*WSCALE ELSE SCALE2 = ASCALE*BSIZE END IF END IF * * End of SLAG2 * RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slag2d.f000066400000000000000000000066511522610125300261360ustar00rootroot00000000000000*> \brief \b SLAG2D converts a single precision matrix to a double precision matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAG2D + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDSA, M, N * .. * .. Array Arguments .. * REAL SA( LDSA, * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE *> PRECISION matrix, A. *> *> Note that while it is possible to overflow while converting *> from double to single, it is not possible to overflow when *> converting from single to double. *> *> This is an auxiliary routine so there is no argument checking. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of lines 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] SA *> \verbatim *> SA is REAL array, dimension (LDSA,N) *> On entry, the M-by-N coefficient matrix SA. *> \endverbatim *> *> \param[in] LDSA *> \verbatim *> LDSA is INTEGER *> The leading dimension of the array SA. LDSA >= max(1,M). *> \endverbatim *> *> \param[out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On exit, the M-by-N coefficient matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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, LDSA, M, N * .. * .. Array Arguments .. REAL SA( LDSA, * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * INFO = 0 DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = SA( I, J ) 10 CONTINUE 20 CONTINUE RETURN * * End of SLAG2D * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slagv2.f000066400000000000000000000246461522610125300261640ustar00rootroot00000000000000*> \brief \b SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAGV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), * $ B( LDB, * ), BETA( 2 ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 *> matrix pencil (A,B) where B is upper triangular. This routine *> computes orthogonal (rotation) matrices given by CSL, SNL and CSR, *> SNR such that *> *> 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 *> types), then *> *> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] *> [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] *> *> [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] *> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], *> *> 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, *> then *> *> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] *> [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] *> *> [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] *> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] *> *> where b11 >= b22 > 0. *> *> \endverbatim * * Arguments: * ========== * *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA, 2) *> On entry, the 2 x 2 matrix A. *> On exit, A is overwritten by the ``A-part'' of the *> generalized Schur form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> THe leading dimension of the array A. LDA >= 2. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is REAL array, dimension (LDB, 2) *> On entry, the upper triangular 2 x 2 matrix B. *> On exit, B is overwritten by the ``B-part'' of the *> generalized Schur form. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> THe leading dimension of the array B. LDB >= 2. *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is REAL array, dimension (2) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is REAL array, dimension (2) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is REAL array, dimension (2) *> (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the *> pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may *> be zero. *> \endverbatim *> *> \param[out] CSL *> \verbatim *> CSL is REAL *> The cosine of the left rotation matrix. *> \endverbatim *> *> \param[out] SNL *> \verbatim *> SNL is REAL *> The sine of the left rotation matrix. *> \endverbatim *> *> \param[out] CSR *> \verbatim *> CSR is REAL *> The cosine of the right rotation matrix. *> \endverbatim *> *> \param[out] SNR *> \verbatim *> SNR is REAL *> The sine of the right rotation matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, LDB REAL CSL, CSR, SNL, SNR * .. * .. Array Arguments .. REAL A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), $ B( LDB, * ), BETA( 2 ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. REAL ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ, $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1, $ WR2 * .. * .. External Subroutines .. EXTERNAL SLAG2, SLARTG, SLASV2, SROT * .. * .. External Functions .. REAL SLAMCH, SLAPY2 EXTERNAL SLAMCH, SLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * SAFMIN = SLAMCH( 'S' ) ULP = SLAMCH( 'P' ) * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A( 1, 1 ) = ASCALE*A( 1, 1 ) A( 1, 2 ) = ASCALE*A( 1, 2 ) A( 2, 1 ) = ASCALE*A( 2, 1 ) A( 2, 2 ) = ASCALE*A( 2, 2 ) * * Scale B * BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ), $ SAFMIN ) BSCALE = ONE / BNORM B( 1, 1 ) = BSCALE*B( 1, 1 ) B( 1, 2 ) = BSCALE*B( 1, 2 ) B( 2, 2 ) = BSCALE*B( 2, 2 ) * * Check if A can be deflated * IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN CSL = ONE SNL = ZERO CSR = ONE SNR = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * * Check if B is singular * ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) CSR = ONE SNR = ZERO CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) A( 2, 1 ) = ZERO B( 1, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN CALL SLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T ) SNR = -SNR CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) CSL = ONE SNL = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO B( 2, 2 ) = ZERO WI = ZERO * ELSE * * B is nonsingular, first compute the eigenvalues of (A,B) * CALL SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, $ WI ) * IF( WI.EQ.ZERO ) THEN * * two real eigenvalues, compute s*A-w*B * H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 ) H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 ) H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 ) * RR = SLAPY2( H1, H2 ) QQ = SLAPY2( SCALE1*A( 2, 1 ), H3 ) * IF( RR.GT.QQ ) THEN * * find right rotation matrix to zero 1,1 element of * (sA - wB) * CALL SLARTG( H2, H1, CSR, SNR, T ) * ELSE * * find right rotation matrix to zero 2,1 element of * (sA - wB) * CALL SLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T ) * END IF * SNR = -SNR CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) * * compute inf norms of A and B * H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ), $ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) ) H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) * IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN * * find left rotation matrix Q to zero out B(2,1) * CALL SLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R ) * ELSE * * find left rotation matrix Q to zero out A(2,1) * CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) * END IF * CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) * A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO * ELSE * * a pair of complex conjugate eigenvalues * first compute the SVD of the matrix B * CALL SLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR, $ CSR, SNL, CSL ) * * Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and * Z is right rotation matrix computed from SLASV2 * CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) * B( 2, 1 ) = ZERO B( 1, 2 ) = ZERO * END IF * END IF * * Unscaling * A( 1, 1 ) = ANORM*A( 1, 1 ) A( 2, 1 ) = ANORM*A( 2, 1 ) A( 1, 2 ) = ANORM*A( 1, 2 ) A( 2, 2 ) = ANORM*A( 2, 2 ) B( 1, 1 ) = BNORM*B( 1, 1 ) B( 2, 1 ) = BNORM*B( 2, 1 ) B( 1, 2 ) = BNORM*B( 1, 2 ) B( 2, 2 ) = BNORM*B( 2, 2 ) * IF( WI.EQ.ZERO ) THEN ALPHAR( 1 ) = A( 1, 1 ) ALPHAR( 2 ) = A( 2, 2 ) ALPHAI( 1 ) = ZERO ALPHAI( 2 ) = ZERO BETA( 1 ) = B( 1, 1 ) BETA( 2 ) = B( 2, 2 ) ELSE ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM ALPHAR( 2 ) = ALPHAR( 1 ) ALPHAI( 2 ) = -ALPHAI( 1 ) BETA( 1 ) = ONE BETA( 2 ) = ONE END IF * RETURN * * End of SLAGV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slahqr.f000066400000000000000000000471121522610125300262510ustar00rootroot00000000000000*> \brief \b SLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAHQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAHQR is an auxiliary routine called by SHSEQR to update the *> eigenvalues and Schur decomposition already computed by SHSEQR, by *> dealing with the Hessenberg submatrix in rows and columns ILO to *> IHI. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper quasi-triangular in *> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless *> ILO = 1). SLAHQR works primarily with the Hessenberg *> submatrix in rows and columns ILO to IHI, but applies *> transformations to all of H if WANTT is .TRUE.. *> 1 <= ILO <= max(1,IHI); IHI <= N. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO is zero and if WANTT is .TRUE., H is upper *> quasi-triangular in rows and columns ILO:IHI, with any *> 2-by-2 diagonal blocks in standard form. If INFO is zero *> and WANTT is .FALSE., the contents of H are unspecified on *> exit. The output state of H if INFO is nonzero is given *> below under the description of INFO. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is REAL array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL array, dimension (N) *> The real and imaginary parts, respectively, of the computed *> eigenvalues ILO to IHI are stored in the corresponding *> elements of WR and WI. If two eigenvalues are computed as a *> complex conjugate pair, they are stored in consecutive *> elements of WR and WI, say the i-th and (i+1)th, with *> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the *> eigenvalues are stored in the same order as on the diagonal *> of the Schur form returned in H, with WR(i) = H(i,i), and, if *> H(i:i+1,i:i+1) is a 2-by-2 diagonal block, *> WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,N) *> If WANTZ is .TRUE., on entry Z must contain the current *> matrix Z of transformations accumulated by SHSEQR, and on *> exit Z has been updated; transformations are applied only to *> the submatrix Z(ILOZ:IHIZ,ILO:IHI). *> If WANTZ is .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: If INFO = i, SLAHQR failed to compute all the *> eigenvalues ILO to IHI in a total of 30 iterations *> per eigenvalue; elements i+1:ihi of WR and WI *> contain those eigenvalues which have been *> successfully computed. *> *> If INFO .GT. 0 and WANTT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the *> eigenvalues of the upper Hessenberg matrix rows *> and columns ILO thorugh INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> (*) (initial value of H)*U = U*(final value of H) *> where U is an orthognal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> (final value of Z) = (initial value of Z)*U *> where U is the orthogonal matrix in (*) *> (regardless of the value of WANTT.) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> 02-96 Based on modifications by *> David Day, Sandia National Laboratory, USA *> *> 12-04 Further modifications by *> Ralph Byers, University of Kansas, USA *> This is a modified version of SLAHQR from LAPACK version 3.0. *> It is (1) more robust against overflow and underflow and *> (2) adopts the more conservative Ahues & Tisseur stopping *> criterion (LAWN 122, 1997). *> \endverbatim *> * ===================================================================== SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * ========================================================= * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0, TWO = 2.0e0 ) REAL DAT1, DAT2 PARAMETER ( DAT1 = 3.0e0 / 4.0e0, DAT2 = -0.4375e0 ) * .. * .. Local Scalars .. REAL AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, $ ULP, V2, V3 INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ * .. * .. Local Arrays .. REAL V( 3 ) * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL SCOPY, SLABAD, SLANV2, SLARFG, SROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * ==== clear out the trash ==== DO 10 J = ILO, IHI - 3 H( J+2, J ) = ZERO H( J+3, J ) = ZERO 10 CONTINUE IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITMAX is the total number of QR iterations allowed. * 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 * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 20 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 160 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * DO 140 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * DO 30 K = I, L + 1, -1 IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) $ GO TO 40 TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST.EQ.ZERO ) THEN IF( K-2.GE.ILO ) $ TST = TST + ABS( H( K-1, K-2 ) ) IF( K+1.LE.IHI ) $ TST = TST + ABS( H( K+1, K ) ) END IF * ==== The following is a conservative small subdiagonal * . deflation criterion due to Ahues & Tisseur (LAWN 122, * . 1997). It has better mathematical foundation and * . improves accuracy in some cases. ==== IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) AA = MAX( ABS( H( K, K ) ), $ ABS( H( K-1, K-1 )-H( K, K ) ) ) BB = MIN( ABS( H( K, K ) ), $ ABS( H( K-1, K-1 )-H( K, K ) ) ) S = AA + AB IF( BA*( AB / S ).LE.MAX( SMLNUM, $ ULP*( BB*( AA / S ) ) ) )GO TO 40 END IF 30 CONTINUE 40 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) $ GO TO 150 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 ) THEN * * Exceptional shift. * S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) H11 = DAT1*S + H( L, L ) H12 = DAT2*S H21 = S H22 = H11 ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H11 = DAT1*S + H( I, I ) H12 = DAT2*S H21 = S H22 = H11 ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * H11 = H( I-1, I-1 ) H21 = H( I, I-1 ) H12 = H( I-1, I ) H22 = H( I, I ) END IF S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) IF( S.EQ.ZERO ) THEN RT1R = ZERO RT1I = ZERO RT2R = ZERO RT2I = ZERO ELSE H11 = H11 / S H21 = H21 / S H12 = H12 / S H22 = H22 / S TR = ( H11+H22 ) / TWO DET = ( H11-TR )*( H22-TR ) - H12*H21 RTDISC = SQRT( ABS( DET ) ) IF( DET.GE.ZERO ) THEN * * ==== complex conjugate shifts ==== * RT1R = TR*S RT2R = RT1R RT1I = RTDISC*S RT2I = -RT1I ELSE * * ==== real shifts (use only one of them) ==== * RT1R = TR + RTDISC RT2R = TR - RTDISC IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN RT1R = RT1R*S RT2R = RT1R ELSE RT2R = RT2R*S RT1R = RT2R END IF RT1I = ZERO RT2I = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 50 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. (The following uses scaling to avoid * overflows and most underflows.) * H21S = H( M+1, M ) S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) H21S = H( M+1, M ) / S V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) V( 3 ) = H21S*H( M+2, M+1 ) S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) V( 1 ) = V( 1 ) / S V( 2 ) = V( 2 ) / S V( 3 ) = V( 3 ) / S IF( M.EQ.L ) $ GO TO 60 IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 50 CONTINUE 60 CONTINUE * * Double-shift QR step * DO 130 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( 3, I-K+1 ) IF( K.GT.M ) $ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL SLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN * ==== Use the following instead of * . H( K, K-1 ) = -H( K, K-1 ) to * . avoid a bug when v(2) and v(3) * . underflow. ==== H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) END IF V2 = V( 2 ) T2 = T1*V2 IF( NR.EQ.3 ) THEN V3 = V( 3 ) T3 = T1*V3 * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 70 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 70 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 80 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 80 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 90 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 90 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 100 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 100 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 110 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 110 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 120 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 120 CONTINUE END IF END IF 130 CONTINUE * 140 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 150 CONTINUE * IF( L.EQ.I ) THEN * * H(I,I-1) is negligible: one eigenvalue has converged. * WR( I ) = H( I, I ) WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN * * H(I-1,I-2) is negligible: a pair of eigenvalues have converged. * * Transform the 2-by-2 submatrix to standard Schur form, * and compute and store the eigenvalues. * CALL SLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), $ CS, SN ) * IF( WANTT ) THEN * * Apply the transformation to the rest of H. * IF( I2.GT.I ) $ CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, $ CS, SN ) CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) END IF IF( WANTZ ) THEN * * Apply the transformation to Z. * CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) END IF END IF * * return to start of the main loop with new value of I. * I = L - 1 GO TO 20 * 160 CONTINUE RETURN * * End of SLAHQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slahr2.f000066400000000000000000000236361522610125300261570ustar00rootroot00000000000000*> \brief \b SLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAHR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. * REAL A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) *> matrix A so that elements below the k-th subdiagonal are zero. The *> reduction is performed by an orthogonal similarity transformation *> Q**T * A * Q. The routine returns the matrices V and T which determine *> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. *> *> This is an auxiliary routine called by SGEHRD. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The offset for the reduction. Elements below the k-th *> subdiagonal in the first NB columns are reduced to zero. *> K < N. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N-K+1) *> On entry, the n-by-(n-k+1) general matrix A. *> On exit, the elements on and above the k-th subdiagonal in *> the first NB columns are overwritten with the corresponding *> elements of the reduced matrix; the elements below the k-th *> subdiagonal, with the array TAU, represent the matrix Q as a *> product of elementary reflectors. The other columns of A are *> unchanged. 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] TAU *> \verbatim *> TAU is REAL array, dimension (NB) *> The scalar factors of the elementary reflectors. See Further *> Details. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is REAL array, dimension (LDT,NB) *> The upper triangular matrix T. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is REAL array, dimension (LDY,NB) *> The n-by-nb matrix Y. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of nb elementary reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in *> A(i+k+1:n,i), and tau in TAU(i). *> *> The elements of the vectors v together form the (n-k+1)-by-nb matrix *> V which is needed, with T and Y, to apply the transformation to the *> unreduced part of the matrix, using an update of the form: *> A := (I - V*T*V**T) * (A - Y*V**T). *> *> The contents of A on exit are illustrated by the following example *> with n = 7, k = 3 and nb = 2: *> *> ( a a a a a ) *> ( a a a a a ) *> ( a a a a a ) *> ( h h a a a ) *> ( v1 h a a a ) *> ( v1 v2 a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This subroutine is a slight modification of LAPACK-3.0's DLAHRD *> incorporating improvements proposed by Quintana-Orti and Van de *> Gejin. Note that the entries of A(1:K,2:NB) differ from those *> returned by the original LAPACK-3.0's DLAHRD routine. (This *> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) *> \endverbatim * *> \par References: * ================ *> *> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the *> performance of reduction to Hessenberg form," ACM Transactions on *> Mathematical Software, 32(2):180-194, June 2006. *> * ===================================================================== SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.7.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 K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. REAL A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, $ ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL EI * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SGEMM, SGEMV, SLACPY, $ SLARFG, SSCAL, STRMM, STRMV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(K+1:N,I) * * Update I-th column of A - Y * V**T * CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) * * Apply I - V * T**T * V**T to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1**T * b1 * CALL SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) 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, $ 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', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * 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', $ '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 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(I) to annihilate * A(K+I+1:N,I) * CALL SLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(K+1:N,I) * 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, $ 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, $ 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 ) * * Compute T(1:I,I) * CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL STRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * * Compute Y(1:K,1:NB) * CALL SLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) 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, $ 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', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * RETURN * * End of SLAHR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaic1.f000066400000000000000000000234651522610125300261400ustar00rootroot00000000000000*> \brief \b SLAIC1 applies one step of incremental condition estimation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAIC1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * .. Scalar Arguments .. * INTEGER J, JOB * REAL C, GAMMA, S, SEST, SESTPR * .. * .. Array Arguments .. * REAL W( J ), X( J ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAIC1 applies one step of incremental condition estimation in *> its simplest version: *> *> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j *> lower triangular matrix L, such that *> twonorm(L*x) = sest *> Then SLAIC1 computes sestpr, s, c such that *> the vector *> [ s*x ] *> xhat = [ c ] *> is an approximate singular vector of *> [ L 0 ] *> Lhat = [ w**T gamma ] *> in the sense that *> twonorm(Lhat*xhat) = sestpr. *> *> Depending on JOB, an estimate for the largest or smallest singular *> value is computed. *> *> Note that [s c]**T and sestpr**2 is an eigenpair of the system *> *> diag(sest*sest, 0) + [alpha gamma] * [ alpha ] *> [ gamma ] *> *> where alpha = x**T*w. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is INTEGER *> = 1: an estimate for the largest singular value is computed. *> = 2: an estimate for the smallest singular value is computed. *> \endverbatim *> *> \param[in] J *> \verbatim *> J is INTEGER *> Length of X and W *> \endverbatim *> *> \param[in] X *> \verbatim *> X is REAL array, dimension (J) *> The j-vector x. *> \endverbatim *> *> \param[in] SEST *> \verbatim *> SEST is REAL *> Estimated singular value of j by j matrix L *> \endverbatim *> *> \param[in] W *> \verbatim *> W is REAL array, dimension (J) *> The j-vector w. *> \endverbatim *> *> \param[in] GAMMA *> \verbatim *> GAMMA is REAL *> The diagonal element gamma. *> \endverbatim *> *> \param[out] SESTPR *> \verbatim *> SESTPR is REAL *> Estimated singular value of (j+1) by (j+1) matrix Lhat. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is REAL *> Sine needed in forming xhat. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is REAL *> Cosine needed in forming xhat. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * -- LAPACK auxiliary routine (version 3.7.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 J, JOB REAL C, GAMMA, S, SEST, SESTPR * .. * .. Array Arguments .. REAL W( J ), X( J ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 ) REAL HALF, FOUR PARAMETER ( HALF = 0.5E0, FOUR = 4.0E0 ) * .. * .. Local Scalars .. REAL ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS, $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. External Functions .. REAL SDOT, SLAMCH EXTERNAL SDOT, SLAMCH * .. * .. Executable Statements .. * EPS = SLAMCH( 'Epsilon' ) ALPHA = SDOT( J, X, 1, W, 1 ) * ABSALP = ABS( ALPHA ) ABSGAM = ABS( GAMMA ) ABSEST = ABS( SEST ) * IF( JOB.EQ.1 ) THEN * * Estimating largest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN S1 = MAX( ABSGAM, ABSALP ) IF( S1.EQ.ZERO ) THEN S = ZERO C = ONE SESTPR = ZERO ELSE S = ALPHA / S1 C = GAMMA / S1 TMP = SQRT( S*S+C*C ) S = S / TMP C = C / TMP SESTPR = S1*TMP END IF RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ONE C = ZERO TMP = MAX( ABSEST, ABSALP ) S1 = ABSEST / TMP S2 = ABSALP / TMP SESTPR = TMP*SQRT( S1*S1+S2*S2 ) RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ONE C = ZERO SESTPR = S2 ELSE S = ZERO C = ONE SESTPR = S1 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 S = SQRT( ONE+TMP*TMP ) SESTPR = S2*S C = ( GAMMA / S2 ) / S S = SIGN( ONE, ALPHA ) / S ELSE TMP = S2 / S1 C = SQRT( ONE+TMP*TMP ) SESTPR = S1*C S = ( ALPHA / S1 ) / C C = SIGN( ONE, GAMMA ) / C END IF RETURN ELSE * * normal case * ZETA1 = ALPHA / ABSEST ZETA2 = GAMMA / ABSEST * B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF C = ZETA1*ZETA1 IF( B.GT.ZERO ) THEN T = C / ( B+SQRT( B*B+C ) ) ELSE T = SQRT( B*B+C ) - B END IF * SINE = -ZETA1 / T COSINE = -ZETA2 / ( ONE+T ) TMP = SQRT( SINE*SINE+COSINE*COSINE ) S = SINE / TMP C = COSINE / TMP SESTPR = SQRT( T+ONE )*ABSEST RETURN END IF * ELSE IF( JOB.EQ.2 ) THEN * * Estimating smallest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN SESTPR = ZERO IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN SINE = ONE COSINE = ZERO ELSE SINE = -GAMMA COSINE = ALPHA END IF S1 = MAX( ABS( SINE ), ABS( COSINE ) ) S = SINE / S1 C = COSINE / S1 TMP = SQRT( S*S+C*C ) S = S / TMP C = C / TMP RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ZERO C = ONE SESTPR = ABSGAM RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ZERO C = ONE SESTPR = S1 ELSE S = ONE C = ZERO SESTPR = S2 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 C = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST*( TMP / C ) S = -( GAMMA / S2 ) / C C = SIGN( ONE, ALPHA ) / C ELSE TMP = S2 / S1 S = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST / S C = ( ALPHA / S1 ) / S S = -SIGN( ONE, GAMMA ) / S END IF RETURN ELSE * * normal case * ZETA1 = ALPHA / ABSEST ZETA2 = GAMMA / ABSEST * NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ), $ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 ) * * See if root is closer to zero or to ONE * TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) IF( TEST.GE.ZERO ) THEN * * root is close to zero, compute directly * B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF C = ZETA2*ZETA2 T = C / ( B+SQRT( ABS( B*B-C ) ) ) SINE = ZETA1 / ( ONE-T ) COSINE = -ZETA2 / T SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST ELSE * * root is closer to ONE, shift by that amount * B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF C = ZETA1*ZETA1 IF( B.GE.ZERO ) THEN T = -C / ( B+SQRT( B*B+C ) ) ELSE T = B - SQRT( B*B+C ) END IF SINE = -ZETA1 / T COSINE = -ZETA2 / ( ONE+T ) SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST END IF TMP = SQRT( SINE*SINE+COSINE*COSINE ) S = SINE / TMP C = COSINE / TMP RETURN * END IF END IF RETURN * * End of SLAIC1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaisnan.f000066400000000000000000000050061522610125300265630ustar00rootroot00000000000000*> \brief \b SLAISNAN tests input for NaN by comparing two arguments for inequality. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAISNAN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 ) * * .. Scalar Arguments .. * REAL SIN1, SIN2 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is not for general use. It exists solely to avoid *> over-optimization in SISNAN. *> *> SLAISNAN checks for NaNs by comparing its two arguments for *> inequality. NaN is the only floating-point value where NaN != NaN *> returns .TRUE. To check for NaNs, pass the same variable as both *> arguments. *> *> A compiler must assume that the two arguments are *> not the same variable, and the test will not be optimized away. *> Interprocedural or whole-program optimization may delete this *> test. The ISNAN functions will be replaced by the correct *> Fortran 03 intrinsic once the intrinsic is widely available. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIN1 *> \verbatim *> SIN1 is REAL *> \endverbatim *> *> \param[in] SIN2 *> \verbatim *> SIN2 is REAL *> Two numbers to compare for inequality. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL SIN1, SIN2 * .. * * ===================================================================== * * .. Executable Statements .. SLAISNAN = (SIN1.NE.SIN2) RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaln2.f000066400000000000000000000447571522610125300261660ustar00rootroot00000000000000*> \brief \b SLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLALN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLALN2 solves a system of the form (ca A - w D ) X = s B *> or (ca A**T - w D) X = s B with possible scaling ("s") and *> perturbation of A. (A**T means A-transpose.) *> *> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA *> real diagonal matrix, w is a real or complex value, and X and B are *> NA x 1 matrices -- real if w is real, complex if w is complex. NA *> may be 1 or 2. *> *> If w is complex, X and B are represented as NA x 2 matrices, *> the first column of each being the real part and the second *> being the imaginary part. *> *> "s" is a scaling factor (.LE. 1), computed by SLALN2, which is *> so chosen that X can be computed without overflow. X is further *> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less *> than overflow. *> *> If both singular values of (ca A - w D) are less than SMIN, *> SMIN*identity will be used instead of (ca A - w D). If only one *> singular value is less than SMIN, one element of (ca A - w D) will be *> perturbed enough to make the smallest singular value roughly SMIN. *> If both singular values are at least SMIN, (ca A - w D) will not be *> perturbed. In any case, the perturbation will be at most some small *> multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values *> are computed by infinity-norm approximations, and thus will only be *> correct to a factor of 2 or so. *> *> Note: all input quantities are assumed to be smaller than overflow *> by a reasonable factor. (See BIGNUM.) *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRANS *> \verbatim *> LTRANS is LOGICAL *> =.TRUE.: A-transpose will be used. *> =.FALSE.: A will be used (not transposed.) *> \endverbatim *> *> \param[in] NA *> \verbatim *> NA is INTEGER *> The size of the matrix A. It may (only) be 1 or 2. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> 1 if "w" is real, 2 if "w" is complex. It may only be 1 *> or 2. *> \endverbatim *> *> \param[in] SMIN *> \verbatim *> SMIN is REAL *> The desired lower bound on the singular values of A. This *> should be a safe distance away from underflow or overflow, *> say, between (underflow/machine precision) and (machine *> precision * overflow ). (See BIGNUM and ULP.) *> \endverbatim *> *> \param[in] CA *> \verbatim *> CA is REAL *> The coefficient c, which A is multiplied by. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,NA) *> The NA x NA matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. It must be at least NA. *> \endverbatim *> *> \param[in] D1 *> \verbatim *> D1 is REAL *> The 1,1 element in the diagonal matrix D. *> \endverbatim *> *> \param[in] D2 *> \verbatim *> D2 is REAL *> The 2,2 element in the diagonal matrix D. Not used if NA=1. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB,NW) *> The NA x NW matrix B (right-hand side). If NW=2 ("w" is *> complex), column 1 contains the real part of B and column 2 *> contains the imaginary part. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. It must be at least NA. *> \endverbatim *> *> \param[in] WR *> \verbatim *> WR is REAL *> The real part of the scalar "w". *> \endverbatim *> *> \param[in] WI *> \verbatim *> WI is REAL *> The imaginary part of the scalar "w". Not used if NW=1. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is REAL array, dimension (LDX,NW) *> The NA x NW matrix X (unknowns), as computed by SLALN2. *> If NW=2 ("w" is complex), on exit, column 1 will contain *> the real part of X and column 2 will contain the imaginary *> part. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of X. It must be at least NA. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> The scale factor that B must be multiplied by to insure *> that overflow does not occur when computing X. Thus, *> (ca A - w D) X will be SCALE*B, not B (ignoring *> perturbations of A.) It will be at most 1. *> \endverbatim *> *> \param[out] XNORM *> \verbatim *> XNORM is REAL *> The infinity-norm of X, when X is regarded as an NA x NW *> real matrix. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> An error flag. It will be set to zero if no error occurs, *> a negative number if an argument is in error, or a positive *> number if ca A - w D had to be perturbed. *> The possible values are: *> = 0: No error occurred, and (ca A - w D) did not have to be *> perturbed. *> = 1: (ca A - w D) had to be perturbed to make its smallest *> (or only) singular value greater than SMIN. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== 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.7.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 LTRANS INTEGER INFO, LDA, LDB, LDX, NA, NW REAL CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) * .. * .. Local Scalars .. INTEGER ICMAX, J REAL BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, $ UR22, XI1, XI2, XR1, XR2 * .. * .. Local Arrays .. LOGICAL CSWAP( 4 ), RSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) REAL CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL SLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Equivalences .. EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), $ ( CR( 1, 1 ), CRV( 1 ) ) * .. * .. Data statements .. DATA CSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / * .. * .. Executable Statements .. * * Compute BIGNUM * SMLNUM = TWO*SLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) * * Don't check for input errors * INFO = 0 * * Standard Initializations * SCALE = ONE * IF( NA.EQ.1 ) THEN * * 1 x 1 (i.e., scalar) system C X = B * IF( NW.EQ.1 ) THEN * * Real 1x1 system. * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CNORM = ABS( CSR ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR XNORM = ABS( X( 1, 1 ) ) ELSE * * Complex 1x1 system (w is complex) * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CSI = -WI*D1 CNORM = ABS( CSR ) + ABS( CSI ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CSI = ZERO CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * CALL SLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, $ X( 1, 1 ), X( 1, 2 ) ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) END IF * ELSE * * 2x2 System * * Compute the real part of C = ca A - w D (or ca A**T - w D ) * CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 IF( LTRANS ) THEN CR( 1, 2 ) = CA*A( 2, 1 ) CR( 2, 1 ) = CA*A( 1, 2 ) ELSE CR( 2, 1 ) = CA*A( 2, 1 ) CR( 1, 2 ) = CA*A( 1, 2 ) END IF * IF( NW.EQ.1 ) THEN * * Real 2x2 system (w is real) * * Find the largest element in C * CMAX = ZERO ICMAX = 0 * DO 10 J = 1, 4 IF( ABS( CRV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) ICMAX = J END IF 10 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) UR11R = ONE / UR11 LR21 = UR11R*CR21 UR22 = CR22 - UR12*LR21 * * If smaller pivot < SMINI, use SMINI * IF( ABS( UR22 ).LT.SMINI ) THEN UR22 = SMINI INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR1 = B( 2, 1 ) BR2 = B( 1, 1 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) END IF BR2 = BR2 - LR21*BR1 BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( UR22 ) ) $ SCALE = ONE / BBND END IF * XR2 = ( BR2*SCALE ) / UR22 XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) IF( CSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 END IF XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF ELSE * * Complex 2x2 system (w is complex) * * Find the largest element in C * CI( 1, 1 ) = -WI*D1 CI( 2, 1 ) = ZERO CI( 1, 2 ) = ZERO CI( 2, 2 ) = -WI*D2 CMAX = ZERO ICMAX = 0 * DO 20 J = 1, 4 IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) ICMAX = J END IF 20 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) X( 1, 2 ) = TEMP*B( 1, 2 ) X( 2, 2 ) = TEMP*B( 2, 2 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) UI11 = CIV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) CI21 = CIV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) UI12 = CIV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) CI22 = CIV( IPIVOT( 4, ICMAX ) ) IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN * * Code when off-diagonals of pivoted C are real * IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN TEMP = UI11 / UR11 UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) UI11R = -TEMP*UR11R ELSE TEMP = UR11 / UI11 UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) UR11R = -TEMP*UI11R END IF LR21 = CR21*UR11R LI21 = CR21*UI11R UR12S = UR12*UR11R UI12S = UR12*UI11R UR22 = CR22 - UR12*LR21 UI22 = CI22 - UR12*LI21 ELSE * * Code when diagonals of pivoted C are real * UR11R = ONE / UR11 UI11R = ZERO LR21 = CR21*UR11R LI21 = CI21*UR11R UR12S = UR12*UR11R UI12S = UI12*UR11R UR22 = CR22 - UR12*LR21 + UI12*LI21 UI22 = -UR12*LI21 - UI12*LR21 END IF U22ABS = ABS( UR22 ) + ABS( UI22 ) * * If smaller pivot < SMINI, use SMINI * IF( U22ABS.LT.SMINI ) THEN UR22 = SMINI UI22 = ZERO INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR2 = B( 1, 1 ) BR1 = B( 2, 1 ) BI2 = B( 1, 2 ) BI1 = B( 2, 2 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) BI1 = B( 1, 2 ) BI2 = B( 2, 2 ) END IF BR2 = BR2 - LR21*BR1 + LI21*BI1 BI2 = BI2 - LI21*BR1 - LR21*BI1 BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), $ ABS( BR2 )+ABS( BI2 ) ) IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN IF( BBND.GE.BIGNUM*U22ABS ) THEN SCALE = ONE / BBND BR1 = SCALE*BR1 BI1 = SCALE*BI1 BR2 = SCALE*BR2 BI2 = SCALE*BI2 END IF END IF * CALL SLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 IF( CSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 X( 1, 2 ) = XI2 X( 2, 2 ) = XI1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 X( 1, 2 ) = XI1 X( 2, 2 ) = XI2 END IF XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) X( 1, 2 ) = TEMP*X( 1, 2 ) X( 2, 2 ) = TEMP*X( 2, 2 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF END IF END IF * RETURN * * End of SLALN2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slamch.f000066400000000000000000000122051522610125300262210ustar00rootroot00000000000000*> \brief \b SLAMCH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SLAMCH( CMACH ) * * .. Scalar Arguments .. * CHARACTER CMACH * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAMCH determines single precision machine parameters. *> \endverbatim * * Arguments: * ========== * *> \param[in] CMACH *> \verbatim *> Specifies the value to be returned by SLAMCH: *> = 'E' or 'e', SLAMCH := eps *> = 'S' or 's , SLAMCH := sfmin *> = 'B' or 'b', SLAMCH := base *> = 'P' or 'p', SLAMCH := eps*base *> = 'N' or 'n', SLAMCH := t *> = 'R' or 'r', SLAMCH := rnd *> = 'M' or 'm', SLAMCH := emin *> = 'U' or 'u', SLAMCH := rmin *> = 'L' or 'l', SLAMCH := emax *> = 'O' or 'o', SLAMCH := rmax *> where *> eps = relative machine precision *> sfmin = safe minimum, such that 1/sfmin does not overflow *> base = base of the machine *> prec = eps*base *> t = number of (base) digits in the mantissa *> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise *> emin = minimum exponent before (gradual) underflow *> rmin = underflow threshold - base**(emin-1) *> emax = largest exponent before overflow *> rmax = overflow threshold - (base**emax)*(1-eps) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 3.7.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 CMACH * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. REAL RND, EPS, SFMIN, SMALL, RMACH * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, $ MINEXPONENT, RADIX, TINY * .. * .. Executable Statements .. * * * Assume rounding, not chopping. Always. * RND = ONE * IF( ONE.EQ.RND ) THEN EPS = EPSILON(ZERO) * 0.5 ELSE EPS = EPSILON(ZERO) END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN SFMIN = TINY(ZERO) SMALL = ONE / HUGE(ZERO) IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = RADIX(ZERO) ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = EPS * RADIX(ZERO) ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = DIGITS(ZERO) ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = MINEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = tiny(zero) ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = MAXEXPONENT(ZERO) ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = HUGE(ZERO) ELSE RMACH = ZERO END IF * SLAMCH = RMACH RETURN * * End of SLAMCH * END ************************************************************************ *> \brief \b SLAMC3 *> \details *> \b Purpose: *> \verbatim *> SLAMC3 is intended to force A and B to be stored prior to doing *> the addition of A and B , for use in situations where optimizers *> 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 December 2016 *> \ingroup auxOTHERauxiliary *> *> \param[in] A *> \verbatim *> \endverbatim *> *> \param[in] B *> \verbatim *> The values A and B. *> \endverbatim *> * REAL FUNCTION SLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * * .. Scalar Arguments .. REAL A, B * .. * ===================================================================== * * .. Executable Statements .. * SLAMC3 = A + B * RETURN * * End of SLAMC3 * END * ************************************************************************ qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slamtsqr.f000066400000000000000000000270251522610125300266260ustar00rootroot00000000000000*> \brief \b SLAMTSQR * * 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] 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slanhs.f000066400000000000000000000131711522610125300262450ustar00rootroot00000000000000*> \brief \b SLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLANHS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N * .. * .. Array Arguments .. * REAL A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLANHS returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> Hessenberg matrix A. *> \endverbatim *> *> \return SLANHS *> \verbatim *> *> SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in SLANHS as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, SLANHS is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> The n by n upper Hessenberg matrix A; the part of A below the *> first sub-diagonal is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 NORM INTEGER LDA, N * .. * .. Array Arguments .. REAL A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * SLANHS = VALUE RETURN * * End of SLANHS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slanst.f000066400000000000000000000122741522610125300262640ustar00rootroot00000000000000*> \brief \b SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLANST + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANST( NORM, N, D, E ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N * .. * .. Array Arguments .. * REAL D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLANST returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real symmetric tridiagonal matrix A. *> \endverbatim *> *> \return SLANST *> \verbatim *> *> SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in SLANST as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, SLANST is *> set to zero. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is REAL array, dimension (N) *> The diagonal elements of A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is REAL array, dimension (N-1) *> The (n-1) sub-diagonal or super-diagonal elements of A. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== REAL FUNCTION SLANST( NORM, N, D, E ) * * -- LAPACK auxiliary routine (version 3.7.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 NORM INTEGER N * .. * .. Array Arguments .. REAL D( * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL ANORM, SCALE, SUM * .. * .. External Functions .. LOGICAL LSAME, SISNAN EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. EXTERNAL SLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 SUM = ABS( D( I ) ) IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM SUM = ABS( E( I ) ) IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. $ LSAME( NORM, 'I' ) ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) SUM = ABS( E( N-1 ) )+ABS( D( N ) ) IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM DO 20 I = 2, N - 1 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL SLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL SLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF * SLANST = ANORM RETURN * * End of SLANST * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slanv2.f000066400000000000000000000166071522610125300261710ustar00rootroot00000000000000*> \brief \b SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLANV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric *> matrix in standard form: *> *> [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] *> [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] *> *> where either *> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or *> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex *> conjugate eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] A *> \verbatim *> A is REAL *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is REAL *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is REAL *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is REAL *> On entry, the elements of the input matrix. *> On exit, they are overwritten by the elements of the *> standardised Schur form. *> \endverbatim *> *> \param[out] RT1R *> \verbatim *> RT1R is REAL *> \endverbatim *> *> \param[out] RT1I *> \verbatim *> RT1I is REAL *> \endverbatim *> *> \param[out] RT2R *> \verbatim *> RT2R is REAL *> \endverbatim *> *> \param[out] RT2I *> \verbatim *> RT2I is REAL *> The real and imaginary parts of the eigenvalues. If the *> eigenvalues are a complex conjugate pair, RT1I > 0. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is REAL *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is REAL *> Parameters of the rotation matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by V. Sima, Research Institute for Informatics, Bucharest, *> Romania, to reduce the risk of cancellation errors, *> when computing real eigenvalues, and to ensure, if possible, that *> abs(RT1R) >= abs(RT2R). *> \endverbatim *> * ===================================================================== SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 ) REAL MULTPL PARAMETER ( MULTPL = 4.0E+0 ) * .. * .. Local Scalars .. REAL AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z * .. * .. External Functions .. REAL SLAMCH, SLAPY2 EXTERNAL SLAMCH, SLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * EPS = SLAMCH( 'P' ) IF( C.EQ.ZERO ) THEN CS = ONE SN = ZERO GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN * * Swap rows and columns * CS = ZERO SN = ONE TEMP = D D = A A = TEMP B = -C C = ZERO GO TO 10 ELSE IF( (A-D).EQ.ZERO .AND. SIGN( ONE, B ).NE. $ SIGN( ONE, C ) ) THEN CS = ONE SN = ZERO GO TO 10 ELSE * TEMP = A - D P = HALF*TEMP BCMAX = MAX( ABS( B ), ABS( C ) ) BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) SCALE = MAX( ABS( P ), BCMAX ) Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS * * If Z is of the order of the machine accuracy, postpone the * decision on the nature of eigenvalues * IF( Z.GE.MULTPL*EPS ) THEN * * Real eigenvalues. Compute A and D. * Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) A = D + Z D = D - ( BCMAX / Z )*BCMIS * * Compute B and the rotation matrix * TAU = SLAPY2( C, Z ) CS = Z / TAU SN = C / TAU B = B - C C = ZERO ELSE * * Complex eigenvalues, or real (almost) equal eigenvalues. * Make diagonal elements equal. * SIGMA = B + C TAU = SLAPY2( SIGMA, TEMP ) CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) * * Compute [ AA BB ] = [ A B ] [ CS -SN ] * [ CC DD ] [ C D ] [ SN CS ] * AA = A*CS + B*SN BB = -A*SN + B*CS CC = C*CS + D*SN DD = -C*SN + D*CS * * Compute [ A B ] = [ CS SN ] [ AA BB ] * [ C D ] [-SN CS ] [ CC DD ] * A = AA*CS + CC*SN B = BB*CS + DD*SN C = -AA*SN + CC*CS D = -BB*SN + DD*CS * TEMP = HALF*( A+D ) A = TEMP D = TEMP * IF( C.NE.ZERO ) THEN IF( B.NE.ZERO ) THEN IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * * Real eigenvalues: reduce to upper triangular form * SAB = SQRT( ABS( B ) ) SAC = SQRT( ABS( C ) ) P = SIGN( SAB*SAC, C ) TAU = ONE / SQRT( ABS( B+C ) ) A = TEMP + P D = TEMP - P B = B - C C = ZERO CS1 = SAB*TAU SN1 = SAC*TAU TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP END IF ELSE B = -C C = ZERO TEMP = CS CS = -SN SN = TEMP END IF END IF END IF * END IF * 10 CONTINUE * * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). * RT1R = A RT2R = D IF( C.EQ.ZERO ) THEN RT1I = ZERO RT2I = ZERO ELSE RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) RT2I = -RT1I END IF RETURN * * End of SLANV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slapy2.f000066400000000000000000000046741522610125300261770ustar00rootroot00000000000000*> \brief \b SLAPY2 returns sqrt(x2+y2). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAPY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLAPY2( X, Y ) * * .. Scalar Arguments .. * REAL X, Y * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary *> overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is REAL *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is REAL *> X and Y specify the values x and y. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== REAL FUNCTION SLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL X, Y * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. REAL W, XABS, YABS, Z * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN SLAPY2 = W ELSE SLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN * * End of SLAPY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slapy3.f000066400000000000000000000052221522610125300261660ustar00rootroot00000000000000*> \brief \b SLAPY3 returns sqrt(x2+y2+z2). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAPY3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLAPY3( X, Y, Z ) * * .. Scalar Arguments .. * REAL X, Y, Z * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause *> unnecessary overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is REAL *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is REAL *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is REAL *> X, Y and Z specify the values x, y and z. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== REAL FUNCTION SLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL X, Y, Z * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) * .. * .. Local Scalars .. REAL W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN * W can be zero for max(0,nan,0) * adding all three entries together will make sure * NaN will not disappear. SLAPY3 = XABS + YABS + ZABS ELSE SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of SLAPY3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqp2.f000066400000000000000000000166751522610125300261730ustar00rootroot00000000000000*> \brief \b SLAQP2 computes a QR factorization with column pivoting of the matrix block. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQP2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) * * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAQP2 computes a QR factorization with column pivoting of *> the block A(OFFSET+1:M,1:N). *> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted *> but no factorized. OFFSET >= 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 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is REAL array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is REAL array, dimension (N) *> The vector with the exact column norms. *> \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 realOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, M, N, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT REAL AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SLAMCH, SNRM2 EXTERNAL ISAMAX, SLAMCH, SNRM2 * .. * .. Executable Statements .. * MN = MIN( M-OFFSET, N ) TOL3Z = SQRT(SLAMCH('Epsilon')) * * Compute factorization. * DO 20 I = 1, MN * OFFPI = OFFSET + I * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 ) + ISAMAX( N-I+1, VN1( I ), 1 ) * IF( PVT.NE.I ) THEN CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP VN1( PVT ) = VN1( I ) VN2( PVT ) = VN2( I ) END IF * * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN CALL SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, $ TAU( I ) ) ELSE CALL SLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i)**T to A(offset+i:m,i+1:n) from the left. * AII = A( OFFPI, I ) A( OFFPI, I ) = ONE CALL SLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) A( OFFPI, I ) = AII END IF * * Update partial column norms. * DO 10 J = I + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( OFFPI.LT.M ) THEN VN1( J ) = SNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) VN2( J ) = VN1( J ) ELSE VN1( J ) = ZERO VN2( J ) = ZERO END IF ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 10 CONTINUE * 20 CONTINUE * RETURN * * End of SLAQP2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqps.f000066400000000000000000000244041522610125300262610ustar00rootroot00000000000000*> \brief \b SLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQPS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * INTEGER JPVT( * ) * REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), * $ VN1( * ), VN2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAQPS computes a step of QR factorization with column pivoting *> of a real M-by-N matrix A by using Blas-3. It tries to factorize *> NB columns from A starting from the row OFFSET+1, and updates all *> of the matrix with Blas-3 xGEMM. *> *> In some cases, due to catastrophic cancellations, it cannot *> factorize NB columns. Hence, the actual number of factorized *> columns is returned in KB. *> *> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of A that have been factorized in *> previous steps. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to factorize. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER *> The number of columns actually factorized. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, block A(OFFSET+1:M,1:KB) is the triangular *> factor obtained and block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. *> The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has *> been updated. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> JPVT(I) = K <==> Column K of the full matrix A has been *> permuted into position I in AP. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL array, dimension (KB) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is REAL array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is REAL array, dimension (N) *> The vector with the exact column norms. *> \endverbatim *> *> \param[in,out] AUXV *> \verbatim *> AUXV is REAL array, dimension (NB) *> Auxiliar vector. *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is REAL array, dimension (LDF,NB) *> Matrix F**T = L*Y**T*A. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * * -- LAPACK auxiliary routine (version 3.7.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 KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), $ VN1( * ), VN2( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK REAL AKK, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL SGEMM, SGEMV, SLARFG, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, NINT, REAL, SQRT * .. * .. External Functions .. INTEGER ISAMAX REAL SLAMCH, SNRM2 EXTERNAL ISAMAX, SLAMCH, SNRM2 * .. * .. Executable Statements .. * LASTRK = MIN( M, N+OFFSET ) LSTICC = 0 K = 0 TOL3Z = SQRT(SLAMCH('Epsilon')) * * Beginning of while loop. * 10 CONTINUE IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN K = K + 1 RK = OFFSET + K * * Determine ith pivot column and swap if necessary * PVT = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 ) IF( PVT.NE.K ) THEN CALL SSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) CALL SSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( K ) JPVT( K ) = ITEMP VN1( PVT ) = VN1( K ) VN2( PVT ) = VN2( K ) END IF * * Apply previous Householder reflectors to column K: * A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. * IF( K.GT.1 ) THEN CALL SGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) END IF * * Generate elementary reflector H(k). * IF( RK.LT.M ) THEN CALL SLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) ELSE CALL SLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) END IF * AKK = A( RK, K ) A( RK, K ) = ONE * * Compute Kth column of F: * * Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). * IF( K.LT.N ) THEN CALL SGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, $ F( K+1, K ), 1 ) END IF * * Padding F(1:K,K) with zeros. * DO 20 J = 1, K F( J, K ) = ZERO 20 CONTINUE * * Incremental updating of F: * F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T * *A(RK:M,K). * IF( K.GT.1 ) THEN CALL SGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) * CALL SGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF, $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) END IF * * Update the current row of A: * A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. * IF( K.LT.N ) THEN CALL SGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) END IF * * Update partial column norms. * IF( RK.LT.LASTRK ) THEN DO 30 J = K + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN VN2( J ) = REAL( LSTICC ) LSTICC = J ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE END IF * A( RK, K ) = AKK * * End of while loop. * GO TO 10 END IF KB = K RK = OFFSET + KB * * Apply the block reflector to the rest of the matrix: * A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - * A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. * IF( KB.LT.MIN( N, M-OFFSET ) ) THEN CALL SGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, $ A( RK+1, KB+1 ), LDA ) END IF * * Recomputation of difficult columns. * 40 CONTINUE IF( LSTICC.GT.0 ) THEN 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 * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP GO TO 40 END IF * RETURN * * End of SLAQPS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqr0.f000066400000000000000000000642371522610125300261700ustar00rootroot00000000000000*> \brief \b SLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQR0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAQR0 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**T, where T is an upper quasi-triangular matrix (the *> Schur form), and Z is the orthogonal matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input orthogonal *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to SGEBAL, and then passed to SGEHRD when the *> matrix output by SGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H contains *> the upper quasi-triangular matrix T from the Schur *> decomposition (the Schur form); 2-by-2 diagonal blocks *> (corresponding to complex conjugate pairs of eigenvalues) *> are returned in standard form, with H(i,i) = H(i+1,i+1) *> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is REAL array, dimension (IHI) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL array, dimension (IHI) *> The real and imaginary parts, respectively, of the computed *> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) *> and WI(ILO:IHI). If two eigenvalues are computed as a *> complex conjugate pair, they are stored in consecutive *> elements of WR and WI, say the i-th and (i+1)th, with *> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then *> the eigenvalues are stored in the same order as on the *> diagonal of the Schur form returned in H, with *> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal *> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and *> WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then SLAQR0 does a workspace query. *> In this case, SLAQR0 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, SLAQR0 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is an orthogonal matrix. The final *> value of H is upper Hessenberg and quasi-triangular *> in rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . SLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== REAL WILK1, WILK2 PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. REAL AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. REAL ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL SLACPY, SLAHQR, SLANV2, SLAQR3, SLAQR4, SLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, MOD, REAL * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use SLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to SLAQR3 ==== * CALL SLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, $ N, H, LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = REAL( LWKOPT ) RETURN END IF * * ==== SLAHQR/SLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 80 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 90 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, $ WORK, LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if SLAQR3 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . SLAQR3 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) AA = WILK1*SS + H( I, I ) BB = SS CC = WILK2*SS DD = AA CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) 30 CONTINUE IF( KS.EQ.KTOP ) THEN WR( KS+1 ) = H( KS+1, KS+1 ) WI( KS+1 ) = ZERO WR( KS ) = WR( KS+1 ) WI( KS ) = WI( KS+1 ) END IF ELSE * * ==== Got NS/2 or fewer shifts? Use SLAQR4 or * . SLAHQR on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL SLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) IF( NS.GT.NMIN ) THEN CALL SLAQR4( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), $ WI( KS ), 1, 1, ZDUM, 1, WORK, $ LWORK, INF ) ELSE CALL SLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), $ WI( KS ), 1, 1, ZDUM, 1, INF ) END IF KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. ==== * IF( KS.GE.KBOT ) THEN AA = H( KBOT-1, KBOT-1 ) CC = H( KBOT, KBOT-1 ) BB = H( KBOT-1, KBOT ) DD = H( KBOT, KBOT ) CALL SLANV2( AA, BB, CC, DD, WR( KBOT-1 ), $ WI( KBOT-1 ), WR( KBOT ), $ WI( KBOT ), CS, SN ) KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) * . Bubble sort keeps complex conjugate * . pairs together. ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN SORTED = .false. * SWAP = WR( I ) WR( I ) = WR( I+1 ) WR( I+1 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I+1 ) WI( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF * * ==== Shuffle shifts into pairs of real shifts * . and pairs of complex conjugate shifts * . assuming complex conjugate shifts are * . already adjacent to one another. (Yes, * . they are.) ==== * DO 70 I = KBOT, KS + 2, -2 IF( WI( I ).NE.-WI( I-1 ) ) THEN * SWAP = WR( I ) WR( I ) = WR( I-1 ) WR( I-1 ) = WR( I-2 ) WR( I-2 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I-1 ) WI( I-1 ) = WI( I-2 ) WI( I-2 ) = SWAP END IF 70 CONTINUE END IF * * ==== If there are only two shifts and both are * . real, then use only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( WI( KBOT ).EQ.ZERO ) THEN IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN WR( KBOT-1 ) = WR( KBOT ) ELSE WR( KBOT ) = WR( KBOT-1 ) END IF END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 80 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 90 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = REAL( LWKOPT ) * * ==== End of SLAQR0 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqr1.f000066400000000000000000000115061522610125300261600ustar00rootroot00000000000000*> \brief \b SLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQR1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * * .. Scalar Arguments .. * REAL SI1, SI2, SR1, SR2 * INTEGER LDH, N * .. * .. Array Arguments .. * REAL H( LDH, * ), V( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a *> scalar multiple of the first column of the product *> *> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) *> *> scaling to avoid overflows and most underflows. It *> is assumed that either *> *> 1) sr1 = sr2 and si1 = -si2 *> or *> 2) si1 = si2 = 0. *> *> This is useful for starting double implicit shift bulges *> in the QR algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is integer *> Order of the matrix H. N must be either 2 or 3. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is REAL array of dimension (LDH,N) *> The 2-by-2 or 3-by-3 matrix H in (*). *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> The leading dimension of H as declared in *> the calling procedure. LDH.GE.N *> \endverbatim *> *> \param[in] SR1 *> \verbatim *> SR1 is REAL *> \endverbatim *> *> \param[in] SI1 *> \verbatim *> SI1 is REAL *> \endverbatim *> *> \param[in] SR2 *> \verbatim *> SR2 is REAL *> \endverbatim *> *> \param[in] SI2 *> \verbatim *> SI2 is REAL *> The shifts in (*). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is REAL array of dimension N *> A scalar multiple of the first column of the *> matrix K in (*). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL SI1, SI2, SR1, SR2 INTEGER LDH, N * .. * .. Array Arguments .. REAL H( LDH, * ), V( * ) * .. * * ================================================================ * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0e0 ) * .. * .. Local Scalars .. REAL H21S, H31S, S * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. IF( N.EQ.2 ) THEN S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO ELSE H21S = H( 2, 1 ) / S V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) END IF ELSE S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + $ ABS( H( 3, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO V( 3 ) = ZERO ELSE H21S = H( 2, 1 ) / S H31S = H( 3, 1 ) / S V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + $ H( 2, 3 )*H31S V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + $ H21S*H( 3, 2 ) END IF END IF END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqr2.f000066400000000000000000000506611522610125300261660ustar00rootroot00000000000000*> \brief \b SLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAQR2 is identical to SLAQR3 except that it avoids *> recursion by calling SLAHQR instead of SLAQR4. *> *> Aggressive early deflation: *> *> This subroutine accepts as input an upper Hessenberg matrix *> H and performs an orthogonal similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an orthogonal similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the quasi-triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the orthogonal matrix Z is updated so *> so that the orthogonal Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the orthogonal matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by an orthogonal *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SR *> \verbatim *> SR is REAL array, dimension KBOT *> \endverbatim *> *> \param[out] SI *> \verbatim *> SI is REAL array, dimension KBOT *> On output, the real and imaginary parts of approximate *> eigenvalues that may be used for shifts are stored in *> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and *> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. *> The real and imaginary parts of converged eigenvalues *> are stored in SR(KBOT-ND+1) through SR(KBOT) and *> SI(KBOT-ND+1) through SI(KBOT), respectively. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is REAL array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is REAL array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is REAL array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension LWORK. *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; SLAQR2 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.7.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 IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), $ V( LDV, * ), WORK( * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, $ LWKOPT LOGICAL BULGE, SORTED * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR, $ SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to SGEHRD ==== * CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to SORMHR ==== * CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = JW + MAX( LWK1, LWK2 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = REAL( LWKOPT ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SR( KWTOP ) = H( KWTOP, KWTOP ) SI( KWTOP ) = ZERO NS = 1 ND = 0 IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) $ THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) * * ==== STREXC needs a clean margin near the diagonal ==== * DO 10 J = 1, JW - 3 T( J+2, J ) = ZERO T( J+3, J ) = ZERO 10 CONTINUE IF( JW.GT.2 ) $ T( JW, JW-2 ) = ZERO * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 20 CONTINUE IF( ILST.LE.NS ) THEN IF( NS.EQ.1 ) THEN BULGE = .FALSE. ELSE BULGE = T( NS, NS-1 ).NE.ZERO END IF * * ==== Small spike tip test for deflation ==== * IF( .NOT.BULGE ) THEN * * ==== Real eigenvalue ==== * FOO = ABS( T( NS, NS ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 1 ELSE * * ==== Undeflatable. Move it up out of the way. * . (STREXC can not fail in this case.) ==== * IFST = NS CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 1 END IF ELSE * * ==== Complex conjugate pair ==== * FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* $ SQRT( ABS( T( NS-1, NS ) ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. $ MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 2 ELSE * * ==== Undeflatable. Move them up out of the way. * . Fortunately, STREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * IFST = NS CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 2 END IF END IF * * ==== End deflation detection loop ==== * GO TO 20 END IF * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting diagonal blocks of T improves accuracy for * . graded matrices. Bubble sort deals well with * . exchange failures. ==== * SORTED = .false. I = NS + 1 30 CONTINUE IF( SORTED ) $ GO TO 50 SORTED = .true. * KEND = I - 1 I = INFQR + 1 IF( I.EQ.NS ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF 40 CONTINUE IF( K.LE.KEND ) THEN IF( K.EQ.I+1 ) THEN EVI = ABS( T( I, I ) ) ELSE EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* $ SQRT( ABS( T( I, I+1 ) ) ) END IF * IF( K.EQ.KEND ) THEN EVK = ABS( T( K, K ) ) ELSE IF( T( K+1, K ).EQ.ZERO ) THEN EVK = ABS( T( K, K ) ) ELSE EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* $ SQRT( ABS( T( K, K+1 ) ) ) END IF * IF( EVI.GE.EVK ) THEN I = K ELSE SORTED = .false. IFST = I ILST = K CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST ELSE I = K END IF END IF IF( I.EQ.KEND ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF GO TO 40 END IF GO TO 30 50 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * I = JW 60 CONTINUE IF( I.GE.INFQR+1 ) THEN IF( I.EQ.INFQR+1 ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE AA = T( I-1, I-1 ) CC = T( I, I-1 ) BB = T( I-1, I ) DD = T( I, I ) CALL SLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), $ SI( KWTOP+I-1 ), CS, SN ) I = I - 2 END IF GO TO 60 END IF * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL SCOPY( NS, V, LDV, WORK, 1 ) BETA = WORK( 1 ) CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) CALL SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 70 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 80 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 80 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 90 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = REAL( LWKOPT ) * * ==== End of SLAQR2 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqr3.f000066400000000000000000000515411522610125300261650ustar00rootroot00000000000000*> \brief \b SLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQR3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Aggressive early deflation: *> *> SLAQR3 accepts as input an upper Hessenberg matrix *> H and performs an orthogonal similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an orthogonal similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the quasi-triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the orthogonal matrix Z is updated so *> so that the orthogonal Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the orthogonal matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by an orthogonal *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SR *> \verbatim *> SR is REAL array, dimension KBOT *> \endverbatim *> *> \param[out] SI *> \verbatim *> SI is REAL array, dimension KBOT *> On output, the real and imaginary parts of approximate *> eigenvalues that may be used for shifts are stored in *> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and *> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. *> The real and imaginary parts of converged eigenvalues *> are stored in SR(KBOT-ND+1) through SR(KBOT) and *> SI(KBOT-ND+1) through SI(KBOT), respectively. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is REAL array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is REAL array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is REAL array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension LWORK. *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; SLAQR3 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), $ V( LDV, * ), WORK( * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, $ LWKOPT, NMIN LOGICAL BULGE, SORTED * .. * .. External Functions .. REAL SLAMCH INTEGER ILAENV EXTERNAL SLAMCH, ILAENV * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR, $ SLANV2, SLAQR4, SLARF, SLARFG, SLASET, SORMHR, $ STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to SGEHRD ==== * CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to SORMHR ==== * CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to SLAQR4 ==== * CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, $ V, LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = REAL( LWKOPT ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SR( KWTOP ) = H( KWTOP, KWTOP ) SI( KWTOP ) = ZERO NS = 1 ND = 0 IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) $ THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'SLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) ELSE CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) END IF * * ==== STREXC needs a clean margin near the diagonal ==== * DO 10 J = 1, JW - 3 T( J+2, J ) = ZERO T( J+3, J ) = ZERO 10 CONTINUE IF( JW.GT.2 ) $ T( JW, JW-2 ) = ZERO * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 20 CONTINUE IF( ILST.LE.NS ) THEN IF( NS.EQ.1 ) THEN BULGE = .FALSE. ELSE BULGE = T( NS, NS-1 ).NE.ZERO END IF * * ==== Small spike tip test for deflation ==== * IF( .NOT. BULGE ) THEN * * ==== Real eigenvalue ==== * FOO = ABS( T( NS, NS ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 1 ELSE * * ==== Undeflatable. Move it up out of the way. * . (STREXC can not fail in this case.) ==== * IFST = NS CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 1 END IF ELSE * * ==== Complex conjugate pair ==== * FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* $ SQRT( ABS( T( NS-1, NS ) ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. $ MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 2 ELSE * * ==== Undeflatable. Move them up out of the way. * . Fortunately, STREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * IFST = NS CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 2 END IF END IF * * ==== End deflation detection loop ==== * GO TO 20 END IF * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting diagonal blocks of T improves accuracy for * . graded matrices. Bubble sort deals well with * . exchange failures. ==== * SORTED = .false. I = NS + 1 30 CONTINUE IF( SORTED ) $ GO TO 50 SORTED = .true. * KEND = I - 1 I = INFQR + 1 IF( I.EQ.NS ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF 40 CONTINUE IF( K.LE.KEND ) THEN IF( K.EQ.I+1 ) THEN EVI = ABS( T( I, I ) ) ELSE EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* $ SQRT( ABS( T( I, I+1 ) ) ) END IF * IF( K.EQ.KEND ) THEN EVK = ABS( T( K, K ) ) ELSE IF( T( K+1, K ).EQ.ZERO ) THEN EVK = ABS( T( K, K ) ) ELSE EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* $ SQRT( ABS( T( K, K+1 ) ) ) END IF * IF( EVI.GE.EVK ) THEN I = K ELSE SORTED = .false. IFST = I ILST = K CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST ELSE I = K END IF END IF IF( I.EQ.KEND ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF GO TO 40 END IF GO TO 30 50 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * I = JW 60 CONTINUE IF( I.GE.INFQR+1 ) THEN IF( I.EQ.INFQR+1 ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE AA = T( I-1, I-1 ) CC = T( I, I-1 ) BB = T( I-1, I ) DD = T( I, I ) CALL SLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), $ SI( KWTOP+I-1 ), CS, SN ) I = I - 2 END IF GO TO 60 END IF * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL SCOPY( NS, V, LDV, WORK, 1 ) BETA = WORK( 1 ) CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) CALL SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 70 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 80 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 80 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 90 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = REAL( LWKOPT ) * * ==== End of SLAQR3 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqr4.f000066400000000000000000000642651522610125300261750ustar00rootroot00000000000000*> \brief \b SLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQR4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAQR4 implements one level of recursion for SLAQR0. *> It is a complete implementation of the small bulge multi-shift *> QR algorithm. It may be called by SLAQR0 and, for large enough *> deflation window size, it may be called by SLAQR3. This *> subroutine is identical to SLAQR0 except that it calls SLAQR2 *> instead of SLAQR3. *> *> SLAQR4 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**T, where T is an upper quasi-triangular matrix (the *> Schur form), and Z is the orthogonal matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input orthogonal *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to SGEBAL, and then passed to SGEHRD when the *> matrix output by SGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H contains *> the upper quasi-triangular matrix T from the Schur *> decomposition (the Schur form); 2-by-2 diagonal blocks *> (corresponding to complex conjugate pairs of eigenvalues) *> are returned in standard form, with H(i,i) = H(i+1,i+1) *> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is REAL array, dimension (IHI) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL array, dimension (IHI) *> The real and imaginary parts, respectively, of the computed *> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) *> and WI(ILO:IHI). If two eigenvalues are computed as a *> complex conjugate pair, they are stored in consecutive *> elements of WR and WI, say the i-th and (i+1)th, with *> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then *> the eigenvalues are stored in the same order as on the *> diagonal of the Schur form returned in H, with *> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal *> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and *> WI(i+1) = -WI(i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then SLAQR4 does a workspace query. *> In this case, SLAQR4 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, SLAQR4 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a orthogonal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . SLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== REAL WILK1, WILK2 PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. REAL AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. REAL ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL SLACPY, SLAHQR, SLANV2, SLAQR2, SLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, MOD, REAL * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use SLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to SLAQR2 ==== * CALL SLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, $ N, H, LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(SLAQR5, SLAQR2) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = REAL( LWKOPT ) RETURN END IF * * ==== SLAHQR/SLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 80 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 90 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, $ WORK, LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if SLAQR2 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . SLAQR2 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) AA = WILK1*SS + H( I, I ) BB = SS CC = WILK2*SS DD = AA CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) 30 CONTINUE IF( KS.EQ.KTOP ) THEN WR( KS+1 ) = H( KS+1, KS+1 ) WI( KS+1 ) = ZERO WR( KS ) = WR( KS+1 ) WI( KS ) = WI( KS+1 ) END IF ELSE * * ==== Got NS/2 or fewer shifts? Use SLAHQR * . on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL SLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) CALL SLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), $ 1, 1, ZDUM, 1, INF ) KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. ==== * IF( KS.GE.KBOT ) THEN AA = H( KBOT-1, KBOT-1 ) CC = H( KBOT, KBOT-1 ) BB = H( KBOT-1, KBOT ) DD = H( KBOT, KBOT ) CALL SLANV2( AA, BB, CC, DD, WR( KBOT-1 ), $ WI( KBOT-1 ), WR( KBOT ), $ WI( KBOT ), CS, SN ) KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) * . Bubble sort keeps complex conjugate * . pairs together. ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN SORTED = .false. * SWAP = WR( I ) WR( I ) = WR( I+1 ) WR( I+1 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I+1 ) WI( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF * * ==== Shuffle shifts into pairs of real shifts * . and pairs of complex conjugate shifts * . assuming complex conjugate shifts are * . already adjacent to one another. (Yes, * . they are.) ==== * DO 70 I = KBOT, KS + 2, -2 IF( WI( I ).NE.-WI( I-1 ) ) THEN * SWAP = WR( I ) WR( I ) = WR( I-1 ) WR( I-1 ) = WR( I-2 ) WR( I-2 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I-1 ) WI( I-1 ) = WI( I-2 ) WI( I-2 ) = SWAP END IF 70 CONTINUE END IF * * ==== If there are only two shifts and both are * . real, then use only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( WI( KBOT ).EQ.ZERO ) THEN IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN WR( KBOT-1 ) = WR( KBOT ) ELSE WR( KBOT ) = WR( KBOT-1 ) END IF END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 80 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 90 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = REAL( LWKOPT ) * * ==== End of SLAQR4 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaqr5.f000066400000000000000000001017341522610125300261670ustar00rootroot00000000000000*> \brief \b SLAQR5 performs a single small-bulge multi-shift QR sweep. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLAQR5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * REAL H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), * $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLAQR5, called by SLAQR0, performs a *> single small-bulge multi-shift QR sweep. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is logical scalar *> WANTT = .true. if the quasi-triangular Schur factor *> is being computed. WANTT is set to .false. otherwise. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is logical scalar *> WANTZ = .true. if the orthogonal Schur factor is being *> computed. WANTZ is set to .false. otherwise. *> \endverbatim *> *> \param[in] KACC22 *> \verbatim *> KACC22 is integer with value 0, 1, or 2. *> Specifies the computation mode of far-from-diagonal *> orthogonal updates. *> = 0: SLAQR5 does not accumulate reflections and does not *> use matrix-matrix multiply to update far-from-diagonal *> matrix entries. *> = 1: SLAQR5 accumulates reflections and uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries. *> = 2: SLAQR5 accumulates reflections, uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries, *> and takes advantage of 2-by-2 block structure during *> matrix multiplies. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is integer scalar *> N is the order of the Hessenberg matrix H upon which this *> subroutine operates. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is integer scalar *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is integer scalar *> These are the first and last rows and columns of an *> isolated diagonal block upon which the QR sweep is to be *> applied. It is assumed without a check that *> either KTOP = 1 or H(KTOP,KTOP-1) = 0 *> and *> either KBOT = N or H(KBOT+1,KBOT) = 0. *> \endverbatim *> *> \param[in] NSHFTS *> \verbatim *> NSHFTS is integer scalar *> NSHFTS gives the number of simultaneous shifts. NSHFTS *> must be positive and even. *> \endverbatim *> *> \param[in,out] SR *> \verbatim *> SR is REAL array of size (NSHFTS) *> \endverbatim *> *> \param[in,out] SI *> \verbatim *> SI is REAL array of size (NSHFTS) *> SR contains the real parts and SI contains the imaginary *> parts of the NSHFTS shifts of origin that define the *> multi-shift QR sweep. On output SR and SI may be *> reordered. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is REAL array of size (LDH,N) *> On input H contains a Hessenberg matrix. On output a *> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied *> to the isolated diagonal block in rows and columns KTOP *> through KBOT. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer scalar *> LDH is the leading dimension of H just as declared in the *> calling procedure. LDH.GE.MAX(1,N). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array of size (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep orthogonal *> similarity transformation is accumulated into *> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer scalar *> LDA is the leading dimension of Z just as declared in *> the calling procedure. LDZ.GE.N. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is REAL array of size (LDV,NSHFTS/2) *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> LDV is the leading dimension of V as declared in the *> calling procedure. LDV.GE.3. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is REAL array of size *> (LDU,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is integer scalar *> LDU is the leading dimension of U just as declared in the *> in the calling subroutine. LDU.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> NH is the number of columns in array WH available for *> workspace. NH.GE.1. *> \endverbatim *> *> \param[out] WH *> \verbatim *> WH is REAL array of size (LDWH,NH) *> \endverbatim *> *> \param[in] LDWH *> \verbatim *> LDWH is integer scalar *> Leading dimension of WH just as declared in the *> calling procedure. LDWH.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer scalar *> NV is the number of rows in WV agailable for workspace. *> NV.GE.1. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is REAL array of size *> (LDWV,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer scalar *> LDWV is the leading dimension of WV as declared in the *> in the calling subroutine. LDWV.GE.NV. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. REAL H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. REAL ALPHA, BETA, H11, H12, H21, H22, REFSUM, $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, $ ULP INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, $ NS, NU LOGICAL ACCUM, BLK22, BMP22 * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. * INTRINSIC ABS, MAX, MIN, MOD, REAL * .. * .. Local Arrays .. REAL VT( 3 ) * .. * .. External Subroutines .. EXTERNAL SGEMM, SLABAD, SLACPY, SLAQR1, SLARFG, SLASET, $ STRMM * .. * .. Executable Statements .. * * ==== If there are no shifts, then there is nothing to do. ==== * IF( NSHFTS.LT.2 ) $ RETURN * * ==== If the active block is empty or 1-by-1, then there * . is nothing to do. ==== * IF( KTOP.GE.KBOT ) $ RETURN * * ==== Shuffle shifts into pairs of real shifts and pairs * . of complex conjugate shifts assuming complex * . conjugate shifts are already adjacent to one * . another. ==== * DO 10 I = 1, NSHFTS - 2, 2 IF( SI( I ).NE.-SI( I+1 ) ) THEN * SWAP = SR( I ) SR( I ) = SR( I+1 ) SR( I+1 ) = SR( I+2 ) SR( I+2 ) = SWAP * SWAP = SI( I ) SI( I ) = SI( I+1 ) SI( I+1 ) = SI( I+2 ) SI( I+2 ) = SWAP END IF 10 CONTINUE * * ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. The shuffle above * . ensures that the dropped shift is real and that * . the remaining shifts are paired. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) * * ==== Machine constants for deflation ==== * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * * ==== Use accumulated reflections to update far-from-diagonal * . entries ? ==== * ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) * * ==== If so, exploit the 2-by-2 block structure? ==== * BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) * * ==== clear trash ==== * IF( KTOP+2.LE.KBOT ) $ H( KTOP+2, KTOP ) = ZERO * * ==== NBMPS = number of 2-shift bulges in the chain ==== * NBMPS = NS / 2 * * ==== KDU = width of slab ==== * KDU = 6*NBMPS - 3 * * ==== Create and chase chains of NBMPS bulges ==== * DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 NDCOL = INCOL + KDU IF( ACCUM ) $ CALL SLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) * * ==== Near-the-diagonal bulge chase. The following loop * . performs the near-the-diagonal part of a small bulge * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal * . chunk extends from column INCOL to column NDCOL * . (including both column INCOL and column NDCOL). The * . following loop chases a 3*NBMPS column long chain of * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL * . may be less than KTOP and and NDCOL may be greater than * . KBOT indicating phantom columns from which to chase * . bulges before they are actually introduced or to which * . to chase bulges beyond column KBOT.) ==== * DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) * * ==== Bulges number MTOP to MBOT are active double implicit * . shift bulges. There may or may not also be small * . 2-by-2 bulge, if there is room. The inactive bulges * . (if any) must wait until the active bulges have moved * . down the diagonal to make room. The phantom matrix * . paradigm described above helps keep track. ==== * MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) M22 = MBOT + 1 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. $ ( KBOT-2 ) * * ==== Generate reflections to chase the chain right * . one column. (The minimum value of K is KTOP-1.) ==== * DO 20 M = MTOP, MBOT K = KRCOL + 3*( M-1 ) IF( K.EQ.KTOP-1 ) THEN CALL SLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ V( 1, M ) ) ALPHA = V( 1, M ) CALL SLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) ELSE BETA = H( K+1, K ) V( 2, M ) = H( K+2, K ) V( 3, M ) = H( K+3, K ) CALL SLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant * . deflation or destructive underflow. In the * . underflow case, try the two-small-subdiagonals * . trick to try to reinflate the bulge. ==== * IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Atypical case: collapsed. Attempt to * . reintroduce ignoring H(K+1,K) and H(K+2,K). * . If the fill resulting from the new * . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL SLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ VT ) ALPHA = VT( 1 ) CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* $ H( K+2, K ) ) * IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ $ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would * . create non-negligible fill. Use * . the old one with trepidation. ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would * . create only negligible fill. * . Replace the old reflector with * . the new one. ==== * H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) V( 2, M ) = VT( 2 ) V( 3, M ) = VT( 3 ) END IF END IF END IF 20 CONTINUE * * ==== Generate a 2-by-2 reflection, if needed. ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF( K.EQ.KTOP-1 ) THEN CALL SLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), $ V( 1, M22 ) ) BETA = V( 1, M22 ) CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) ELSE BETA = H( K+1, K ) V( 2, M22 ) = H( K+2, K ) CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF END IF * * ==== Multiply H by reflections from the left ==== * IF( ACCUM ) THEN JBOT = MIN( NDCOL, KBOT ) ELSE IF( WANTT ) THEN JBOT = N ELSE JBOT = KBOT END IF DO 40 J = MAX( KTOP, KRCOL ), JBOT MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) DO 30 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 30 CONTINUE 40 CONTINUE IF( BMP22 ) THEN K = KRCOL + 3*( M22-1 ) DO 50 J = MAX( K+1, KTOP ), JBOT REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* $ H( K+2, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 50 CONTINUE END IF * * ==== Multiply H by reflections from the right. * . Delay filling in the last row until the * . vigilant deflation check is complete. ==== * IF( ACCUM ) THEN JTOP = MAX( KTOP, INCOL ) ELSE IF( WANTT ) THEN JTOP = 1 ELSE JTOP = KTOP END IF DO 90 M = MTOP, MBOT IF( V( 1, M ).NE.ZERO ) THEN K = KRCOL + 3*( M-1 ) DO 60 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) 60 CONTINUE * IF( ACCUM ) THEN * * ==== Accumulate U. (If necessary, update Z later * . with with an efficient matrix-matrix * . multiply.) ==== * KMS = K - INCOL DO 70 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) 70 CONTINUE ELSE IF( WANTZ ) THEN * * ==== U is not accumulated, so update Z * . now by multiplying by reflections * . from the right. ==== * DO 80 J = ILOZ, IHIZ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) 80 CONTINUE END IF END IF 90 CONTINUE * * ==== Special case: 2-by-2 reflection (if needed) ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF ( V( 1, M22 ).NE.ZERO ) THEN DO 100 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* $ H( J, K+2 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) 100 CONTINUE * IF( ACCUM ) THEN KMS = K - INCOL DO 110 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ $ V( 2, M22 )*U( J, KMS+2 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM* $ V( 2, M22 ) 110 CONTINUE ELSE IF( WANTZ ) THEN DO 120 J = ILOZ, IHIZ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* $ Z( J, K+2 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) 120 CONTINUE END IF END IF END IF * * ==== Vigilant deflation check ==== * MSTART = MTOP IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) $ MSTART = MSTART + 1 MEND = MBOT IF( BMP22 ) $ MEND = MEND + 1 IF( KRCOL.EQ.KBOT-2 ) $ MEND = MEND + 1 DO 130 M = MSTART, MEND K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) * * ==== The following convergence test requires that * . the tradition small-compared-to-nearby-diagonals * . criterion and the Ahues & Tisseur (LAWN 122, 1997) * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 * . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) IF( TST1.EQ.ZERO ) THEN IF( K.GE.KTOP+1 ) $ TST1 = TST1 + ABS( H( K, K-1 ) ) IF( K.GE.KTOP+2 ) $ TST1 = TST1 + ABS( H( K, K-2 ) ) IF( K.GE.KTOP+3 ) $ TST1 = TST1 + ABS( H( K, K-3 ) ) IF( K.LE.KBOT-2 ) $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) IF( K.LE.KBOT-3 ) $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) IF( K.LE.KBOT-4 ) $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) END IF IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) $ THEN H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) H11 = MAX( ABS( H( K+1, K+1 ) ), $ ABS( H( K, K )-H( K+1, K+1 ) ) ) H22 = MIN( ABS( H( K+1, K+1 ) ), $ ABS( H( K, K )-H( K+1, K+1 ) ) ) SCL = H11 + H12 TST2 = H22*( H11 / SCL ) * IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO END IF END IF 130 CONTINUE * * ==== Fill in the last row of each bulge. ==== * MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) DO 140 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) H( K+4, K+1 ) = -REFSUM H( K+4, K+2 ) = -REFSUM*V( 2, M ) H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) 140 CONTINUE * * ==== End of near-the-diagonal bulge chase. ==== * 150 CONTINUE * * ==== Use U (if accumulated) to update far-from-diagonal * . entries in H. If required, use U to update Z as * . well. ==== * IF( ACCUM ) THEN IF( WANTT ) THEN JTOP = 1 JBOT = N ELSE JTOP = KTOP JBOT = KBOT END IF IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN * * ==== Updates not exploiting the 2-by-2 block * . structure of U. K1 and NU keep track of * . the location and size of U in the special * . cases of introducing bulges and chasing * . bulges off the bottom. In these special * . cases and in case the number of shifts * . is NS = 2, there is no 2-by-2 block * . structure to exploit. ==== * K1 = MAX( 1, KTOP-INCOL ) NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 * * ==== Horizontal Multiply ==== * DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) CALL SGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, $ LDWH ) CALL SLACPY( 'ALL', NU, JLEN, WH, LDWH, $ H( INCOL+K1, JCOL ), LDH ) 160 CONTINUE * * ==== Vertical multiply ==== * DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV, $ H( JROW, INCOL+K1 ), LDH ) 170 CONTINUE * * ==== Z multiply (also vertical) ==== * IF( WANTZ ) THEN DO 180 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV, $ Z( JROW, INCOL+K1 ), LDZ ) 180 CONTINUE END IF ELSE * * ==== Updates exploiting U's 2-by-2 block structure. * . (I2, I4, J2, J4 are the last rows and columns * . of the blocks.) ==== * I2 = ( KDU+1 ) / 2 I4 = KDU J2 = I4 - I2 J4 = KDU * * ==== KZS and KNZ deal with the band of zeros * . along the diagonal of one of the triangular * . blocks. ==== * KZS = ( J4-J2 ) - ( NS+1 ) KNZ = NS + 1 * * ==== Horizontal multiply ==== * DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) * * ==== Copy bottom of H to top+KZS of scratch ==== * (The first KZS rows get multiplied by zero.) ==== * CALL SLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), $ LDH, WH( KZS+1, 1 ), LDWH ) * * ==== Multiply by U21**T ==== * CALL SLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) CALL STRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), $ LDWH ) * * ==== Multiply top of H by U11**T ==== * CALL SGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * * ==== Copy top of H to bottom of WH ==== * CALL SLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U21**T ==== * CALL STRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U22 ==== * CALL SGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, $ U( J2+1, I2+1 ), LDU, $ H( INCOL+1+J2, JCOL ), LDH, ONE, $ WH( I2+1, 1 ), LDWH ) * * ==== Copy it back ==== * CALL SLACPY( 'ALL', KDU, JLEN, WH, LDWH, $ H( INCOL+1, JCOL ), LDH ) 190 CONTINUE * * ==== Vertical multiply ==== * DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) * * ==== Copy right of H to scratch (the first KZS * . columns get multiplied by zero) ==== * CALL SLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), $ LDH, WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U21 ==== * CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, $ LDWV ) * * ==== Copy left of H to right of scratch ==== * CALL SLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, $ WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U22 ==== * CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ H( JROW, INCOL+1+J2 ), LDH, $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), $ LDWV ) * * ==== Copy it back ==== * CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ H( JROW, INCOL+1 ), LDH ) 200 CONTINUE * * ==== Multiply Z (also vertical) ==== * IF( WANTZ ) THEN DO 210 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) * * ==== Copy right of Z to left of scratch (first * . KZS columns get multiplied by zero) ==== * CALL SLACPY( 'ALL', JLEN, KNZ, $ Z( JROW, INCOL+1+J2 ), LDZ, $ WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U12 ==== * CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, $ LDWV ) CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, $ WV, LDWV ) * * ==== Copy left of Z to right of scratch ==== * CALL SLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), $ LDZ, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), $ LDWV ) * * ==== Multiply by U22 ==== * CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ Z( JROW, INCOL+1+J2 ), LDZ, $ U( J2+1, I2+1 ), LDU, ONE, $ WV( 1, 1+I2 ), LDWV ) * * ==== Copy the result back to Z ==== * CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ Z( JROW, INCOL+1 ), LDZ ) 210 CONTINUE END IF END IF END IF 220 CONTINUE * * ==== End of SLAQR5 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slarf.f000066400000000000000000000140261522610125300260640ustar00rootroot00000000000000*> \brief \b SLARF applies an elementary reflector to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * REAL TAU * .. * .. Array Arguments .. * REAL C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARF applies a real elementary reflector H to a real m by n matrix *> C, from either the left or the right. H is represented in the form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar and v is a real vector. *> *> If tau = 0, then H is taken to be the unit matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of H. V is not used if *> TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \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, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER INCV, LDC, M, N REAL TAU * .. * .. Array Arguments .. REAL C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER * .. * .. External Functions .. LOGICAL LSAME INTEGER ILASLR, ILASLC EXTERNAL LSAME, ILASLR, ILASLC * .. * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) LASTV = 0 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end ! of V. IF( APPLYLEFT ) THEN LASTV = M ELSE LASTV = N END IF IF( INCV.GT.0 ) THEN I = 1 + (LASTV-1) * INCV ELSE I = 1 END IF ! Look for the last non-zero row in V. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). LASTC = ILASLC(LASTV, N, C, LDC) ELSE ! Scan for the last non-zero row in C(:,1:lastv). LASTC = ILASLR(M, LASTV, C, LDC) END IF END IF ! Note that lastc.eq.0 renders the BLAS operations null; no special ! case is needed at this level. IF( APPLYLEFT ) THEN * * Form H * C * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) * CALL SGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T * CALL SGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) * CALL SGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, $ V, INCV, ZERO, WORK, 1 ) * * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T * CALL SGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of SLARF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slarfb.f000066400000000000000000000512231522610125300262260ustar00rootroot00000000000000*> \brief \b SLARFB applies a block reflector or its transpose to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARFB applies a real block reflector H or its transpose H**T to a *> real m by n matrix C, from either the left or the right. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**T from the Left *> = 'R': apply H or H**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'T': apply H**T (Transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columnwise *> = 'R': Rowwise *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T (= the number of elementary *> reflectors whose product defines the block reflector). *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The matrix V. See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is REAL array, dimension (LDT,K) *> The triangular k by k matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \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 H*C or H**T*C or C*H or C*H**T. *> \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, dimension (LDWORK,K) *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= max(1,N); *> if SIDE = 'R', LDWORK >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2013 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored; the corresponding *> array elements are modified but restored on exit. The rest of the *> array is not used. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEMM, STRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**T * V2 * CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1 * CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W**T * CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * IF( N.GT.K ) THEN * * C1 := C1 - W * V1**T * CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**T * V2**T * CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2**T * CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * IF( M.GT.K ) THEN * * C1 := C1 - V1**T * W**T * CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of SLARFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slarfg.f000066400000000000000000000115241522610125300262330ustar00rootroot00000000000000*> \brief \b SLARFG generates an elementary reflector (Householder matrix). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARFG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) * * .. Scalar Arguments .. * INTEGER INCX, N * REAL ALPHA, TAU * .. * .. Array Arguments .. * REAL X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARFG generates a real elementary reflector H of order n, such *> that *> *> H * ( alpha ) = ( beta ), H**T * H = I. *> ( x ) ( 0 ) *> *> where alpha and beta are scalars, and x is an (n-1)-element real *> vector. H is represented in the form *> *> H = I - tau * ( 1 ) * ( 1 v**T ) , *> ( v ) *> *> where tau is a real scalar and v is a real (n-1)-element *> vector. *> *> If the elements of x are all zero, then tau = 0 and H is taken to be *> the unit matrix. *> *> Otherwise 1 <= tau <= 2. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the elementary reflector. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is REAL *> On entry, the value alpha. *> On exit, it is overwritten with the value beta. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is REAL array, dimension *> (1+(N-2)*abs(INCX)) *> On entry, the vector x. *> On exit, it is overwritten with the vector v. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is REAL *> The value tau. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N REAL ALPHA, TAU * .. * .. Array Arguments .. REAL X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER J, KNT REAL BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. REAL SLAMCH, SLAPY2, SNRM2 EXTERNAL SLAMCH, SLAPY2, SNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL SSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = SNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' ) KNT = 0 IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN 10 CONTINUE KNT = KNT + 1 CALL SSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = SNRM2( N-1, X, INCX ) BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) END IF TAU = ( BETA-ALPHA ) / BETA CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * DO 20 J = 1, KNT BETA = BETA*SAFMIN 20 CONTINUE ALPHA = BETA END IF * RETURN * * End of SLARFG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slarft.f000066400000000000000000000237601522610125300262550ustar00rootroot00000000000000*> \brief \b SLARFT forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARFT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * REAL T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARFT forms the triangular factor T of a real block reflector H *> of order n, which is defined as a product of k elementary reflectors. *> *> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; *> *> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. *> *> If STOREV = 'C', the vector which defines the elementary reflector *> H(i) is stored in the i-th column of the array V, and *> *> H = I - V * T * V**T *> *> If STOREV = 'R', the vector which defines the elementary reflector *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**T * T * V *> \endverbatim * * Arguments: * ========== * *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies the order in which the elementary reflectors are *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): *> = 'C': columnwise *> = 'R': rowwise *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the block reflector H. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the triangular factor T (= the number of *> elementary reflectors). K >= 1. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,N) if STOREV = 'R' *> The matrix V. See further details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is REAL array, dimension (LDT,K) *> The k by k triangular factor T of the block reflector. *> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is *> lower triangular. The rest of the array is not used. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. REAL T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. EXTERNAL SGEMV, STRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN PREVLASTV = N DO I = 1, K PREVLASTV = MAX( I, PREVLASTV ) IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = 1, I T( J, I ) = ZERO END DO ELSE * * general case * IF( LSAME( STOREV, 'C' ) ) THEN * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( I , J ) 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 SGEMV( '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. DO LASTV = N, I+1, -1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) 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, $ ONE, T( 1, I ), 1 ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) IF( I.GT.1 ) THEN PREVLASTV = MAX( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF END DO ELSE PREVLASTV = 1 DO I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = I, K T( J, I ) = ZERO END DO ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( N-K+I , J ) 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) * CALL SGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, $ T( I+1, I ), 1 ) ELSE * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) 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 * CALL SGEMV( 'No transpose', K-I, N-K+I-J, $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, $ ONE, T( I+1, I ), 1 ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) IF( I.GT.1 ) THEN PREVLASTV = MIN( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF T( I, I ) = TAU( I ) END IF END DO END IF RETURN * * End of SLARFT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slarfx.f000066400000000000000000000453321522610125300262600ustar00rootroot00000000000000*> \brief \b SLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARFX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N * REAL TAU * .. * .. Array Arguments .. * REAL C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARFX applies a real elementary reflector H to a real m by n *> matrix C, from either the left or the right. H is represented in the *> form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar and v is a real vector. *> *> If tau = 0, then H is taken to be the unit matrix *> *> This version uses inline code if H has order < 11. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension (M) if SIDE = 'L' *> or (N) if SIDE = 'R' *> The vector v in the representation of H. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDA >= (1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> WORK is not referenced if H has order < 11. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER LDC, M, N REAL TAU * .. * .. Array Arguments .. REAL C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER J REAL SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLARF * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * CALL SLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * CALL SLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 RETURN * * End of SLARFX * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slarnv.f000066400000000000000000000112461522610125300262630ustar00rootroot00000000000000*> \brief \b SLARNV returns a vector of random numbers from a uniform or normal distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARNV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARNV( IDIST, ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER IDIST, N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * REAL X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARNV returns a vector of n random real numbers from a uniform or *> normal distribution. *> \endverbatim * * Arguments: * ========== * *> \param[in] IDIST *> \verbatim *> IDIST is INTEGER *> Specifies the distribution of the random numbers: *> = 1: uniform (0,1) *> = 2: uniform (-1,1) *> = 3: normal (0,1) *> \endverbatim *> *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is REAL array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine calls the auxiliary routine SLARUV to generate random *> real numbers from a uniform (0,1) distribution, in batches of up to *> 128 using vectorisable code. The Box-Muller method is used to *> transform numbers from a uniform to a normal distribution. *> \endverbatim *> * ===================================================================== SUBROUTINE SLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.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 IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, TWO PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) INTEGER LV PARAMETER ( LV = 128 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IL2, IV * .. * .. Local Arrays .. REAL U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL SLARUV * .. * .. Executable Statements .. * DO 40 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) IF( IDIST.EQ.3 ) THEN IL2 = 2*IL ELSE IL2 = IL END IF * * Call SLARUV to generate IL2 numbers from a uniform (0,1) * distribution (IL2 <= LV) * CALL SLARUV( ISEED, IL2, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = U( I ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = TWO*U( I ) - ONE 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ COS( TWOPI*U( 2*I ) ) 30 CONTINUE END IF 40 CONTINUE RETURN * * End of SLARNV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slartg.f000066400000000000000000000125171522610125300262540ustar00rootroot00000000000000*> \brief \b SLARTG generates a plane rotation with real cosine and real sine. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARTG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARTG( F, G, CS, SN, R ) * * .. Scalar Arguments .. * REAL CS, F, G, R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARTG generate a plane rotation so that *> *> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. *> [ -SN CS ] [ G ] [ 0 ] *> *> This is a slower, more accurate version of the BLAS1 routine SROTG, *> with the following other differences: *> F and G are unchanged on return. *> If G=0, then CS=1 and SN=0. *> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any *> floating point operations (saves work in SBDSQR when *> there are zeros on the diagonal). *> *> If F exceeds G in magnitude, CS will be positive. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is REAL *> The first component of vector to be rotated. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is REAL *> The second component of vector to be rotated. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is REAL *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is REAL *> The sine of the rotation. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is REAL *> The nonzero component of the rotated vector. *> *> This version has a few statements commented out for thread safety *> (machine parameters are computed on each entry). 10 feb 03, SJH. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL CS, F, G, R, SN * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. * DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * * IF( FIRST ) THEN SAFMIN = SLAMCH( 'S' ) EPS = SLAMCH( 'E' ) SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( SLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 * FIRST = .FALSE. * END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of SLARTG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaruv.f000066400000000000000000000442151522610125300262740ustar00rootroot00000000000000*> \brief \b SLARUV returns a vector of n random real numbers from a uniform distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLARUV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARUV( ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * REAL X( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLARUV returns a vector of n random real numbers from a uniform (0,1) *> distribution (n <= 128). *> *> This is an auxiliary routine called by SLARNV and CLARNV. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. N <= 128. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is REAL array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine uses a multiplicative congruential method with modulus *> 2**48 and multiplier 33952834046453 (see G.S.Fishman, *> 'Multiplicative congruential random number generators with modulus *> 2**b: an exhaustive analysis for b = 32 and a partial analysis for *> b = 48', Math. Comp. 189, pp 331-344, 1990). *> *> 48-bit integers are stored in 4 integer array elements with 12 bits *> per element. Hence the routine is portable across machines with *> integers of 32 bits or more. *> \endverbatim *> * ===================================================================== SUBROUTINE SLARUV( ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.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 N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL X( N ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) INTEGER LV, IPW2 REAL R PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J * .. * .. Local Arrays .. INTEGER MM( LV, 4 ) * .. * .. Intrinsic Functions .. INTRINSIC MIN, MOD, REAL * .. * .. Data statements .. DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, $ 2549 / DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, $ 1145 / DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, $ 2253 / DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, $ 305 / DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, $ 3301 / DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, $ 1065 / DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, $ 3133 / DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, $ 2913 / DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, $ 3285 / DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, $ 1241 / DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, $ 1197 / DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, $ 3729 / DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, $ 2501 / DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, $ 1673 / DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, $ 541 / DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, $ 2753 / DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, $ 949 / DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, $ 2361 / DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, $ 1165 / DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, $ 4081 / DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, $ 2725 / DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, $ 3305 / DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, $ 3069 / DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, $ 3617 / DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, $ 3733 / DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, $ 409 / DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, $ 2157 / DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, $ 1361 / DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, $ 3973 / DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, $ 1865 / DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, $ 2525 / DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, $ 1409 / DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, $ 3445 / DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, $ 3577 / DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, $ 77 / DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, $ 3761 / DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, $ 2149 / DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, $ 1449 / DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, $ 3005 / DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, $ 225 / DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, $ 85 / DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, $ 3673 / DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, $ 3117 / DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, $ 3089 / DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, $ 1349 / DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, $ 2057 / DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, $ 413 / DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, $ 65 / DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, $ 1845 / DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, $ 697 / DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, $ 3085 / DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, $ 3441 / DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, $ 1573 / DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, $ 3689 / DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, $ 2941 / DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, $ 929 / DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, $ 533 / DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, $ 2841 / DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, $ 4077 / DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, $ 721 / DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, $ 2821 / DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, $ 2249 / DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, $ 2397 / DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, $ 2817 / DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, $ 245 / DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, $ 1913 / DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, $ 1997 / DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, $ 3121 / DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, $ 997 / DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, $ 1833 / DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, $ 2877 / DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, $ 1633 / DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, $ 981 / DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, $ 2009 / DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, $ 941 / DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, $ 2449 / DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, $ 197 / DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, $ 2441 / DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, $ 285 / DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, $ 1473 / DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, $ 2741 / DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, $ 3129 / DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, $ 909 / DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, $ 2801 / DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, $ 421 / DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, $ 4073 / DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, $ 2813 / DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, $ 2337 / DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, $ 1429 / DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, $ 1177 / DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, $ 1901 / DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, $ 81 / DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, $ 1669 / DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, $ 2633 / DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, $ 2269 / DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, $ 129 / DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, $ 1141 / DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, $ 249 / DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, $ 3917 / DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, $ 2481 / DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, $ 3941 / DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, $ 2217 / DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, $ 2749 / DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, $ 3041 / DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, $ 1877 / DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, $ 345 / DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, $ 2861 / DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, $ 1809 / DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, $ 3141 / DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, $ 2825 / DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, $ 157 / DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, $ 2881 / DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, $ 3637 / DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, $ 1465 / DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, $ 2829 / DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, $ 2161 / DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, $ 3365 / DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, $ 361 / DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, $ 2685 / DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, $ 3745 / DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, $ 2325 / DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, $ 3609 / DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, $ 3821 / DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, $ 3537 / DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, $ 517 / DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, $ 3017 / DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, $ 2141 / DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, $ 1537 / * .. * .. Executable Statements .. * I1 = ISEED( 1 ) I2 = ISEED( 2 ) I3 = ISEED( 3 ) 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 * IT4 = I4*MM( I, 4 ) IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + $ I4*MM( I, 1 ) IT1 = MOD( IT1, IPW2 ) * * Convert 48-bit integer to a real number in the interval (0,1) * 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 * will occur about once every 2**n calls), then X( I ) will * be rounded to exactly 1.0. In IEEE single precision arithmetic, * this will happen relatively often since n = 24. * 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. I1 = I1 + 2 I2 = I2 + 2 I3 = I3 + 2 I4 = I4 + 2 GOTO 20 END IF * 10 CONTINUE * * Return final value of seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 RETURN * * End of SLARUV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slascl.f000066400000000000000000000233631522610125300262420ustar00rootroot00000000000000*> \brief \b SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASCL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL CFROM, CTO * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLASCL multiplies the M by N real matrix A by the real scalar *> CTO/CFROM. This is done without over/underflow as long as the final *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that *> A may be full, upper triangular, lower triangular, upper Hessenberg, *> or banded. *> \endverbatim * * Arguments: * ========== * *> \param[in] TYPE *> \verbatim *> TYPE is CHARACTER*1 *> TYPE indices the storage type of the input matrix. *> = 'G': A is a full matrix. *> = 'L': A is a lower triangular matrix. *> = 'U': A is an upper triangular matrix. *> = 'H': A is an upper Hessenberg matrix. *> = 'B': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the lower *> half stored. *> = 'Q': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the upper *> half stored. *> = 'Z': A is a band matrix with lower bandwidth KL and upper *> bandwidth KU. See SGBTRF for storage details. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The lower bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The upper bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] CFROM *> \verbatim *> CFROM is REAL *> \endverbatim *> *> \param[in] CTO *> \verbatim *> CTO is REAL *> *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed *> without over/underflow if the final result CTO*A(I,J)/CFROM *> can be represented without over/underflow. CFROM must be *> nonzero. *> \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,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> The matrix to be multiplied by CTO/CFROM. See TYPE for the *> storage type. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> 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 *> \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 June 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 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 TYPE INTEGER INFO, KL, KU, LDA, M, N REAL CFROM, CTO * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME, SISNAN REAL SLAMCH EXTERNAL LSAME, SLAMCH, SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN INFO = -4 ELSE IF( SISNAN(CTO) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM IF( CFROM1.EQ.CFROMC ) THEN ! CFROMC is an inf. Multiply by a correctly signed zero for ! finite CTOC, or a NaN if CTOC is infinite. MUL = CTOC / CFROMC DONE = .TRUE. CTO1 = CTOC ELSE CTO1 = CTOC / BIGNUM IF( CTO1.EQ.CTOC ) THEN ! CTOC is either 0 or an inf. In both cases, CTOC itself ! serves as the correct multiplication factor. MUL = CTOC DONE = .TRUE. CFROMC = ONE ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of SLASCL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaset.f000066400000000000000000000114301522610125300262440ustar00rootroot00000000000000*> \brief \b SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASET + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N * REAL ALPHA, BETA * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLASET initializes an m-by-n matrix A to BETA on the diagonal and *> ALPHA on the offdiagonals. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be set. *> = 'U': Upper triangular part is set; the strictly lower *> triangular part of A is not changed. *> = 'L': Lower triangular part is set; the strictly upper *> triangular part of A is not changed. *> Otherwise: All of the matrix A is set. *> \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] ALPHA *> \verbatim *> ALPHA is REAL *> The constant to which the offdiagonal elements are to be set. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is REAL *> The constant to which the diagonal elements are to be set. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On exit, the leading m-by-n submatrix of A is set as follows: *> *> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, *> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, *> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, *> *> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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, M, N REAL ALPHA, BETA * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the strictly upper triangular or trapezoidal part of the * array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the strictly lower triangular or trapezoidal part of the * array to ALPHA. * DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE * ELSE * * Set the leading m-by-n submatrix to ALPHA. * DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE END IF * * Set the first min(M,N) diagonal elements to BETA. * DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE * RETURN * * End of SLASET * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slasr.f000066400000000000000000000352421522610125300261040ustar00rootroot00000000000000*> \brief \b SLASR applies a sequence of plane rotations to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), C( * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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 ) *> ( c(k) s(k) ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( c(k) s(k) ) *> ( 1 ) *> ( ... ) *> ( 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> Specifies whether the plane rotation matrix P is applied to *> A on the left or the right. *> = 'L': Left, compute A := P*A *> = 'R': Right, compute A:= A*P**T *> \endverbatim *> *> \param[in] PIVOT *> \verbatim *> PIVOT is CHARACTER*1 *> Specifies the plane for which P(k) is a plane rotation *> matrix. *> = 'V': Variable pivot, the plane (k,k+1) *> = 'T': Top pivot, the plane (1,k+1) *> = 'B': Bottom pivot, the plane (k,z) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies whether P is a forward or backward sequence of *> plane rotations. *> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) *> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. If m <= 1, an immediate *> return is effected. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. If n <= 1, an *> immediate return is effected. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is REAL array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The cosines c(k) of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is REAL array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The sines s(k) of the plane rotations. The 2-by-2 plane *> rotation part of the matrix P(k), R(k), has the form *> R(k) = ( c(k) s(k) ) *> ( -s(k) c(k) ). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> The M-by-N matrix A. On exit, A is overwritten by P*A if *> SIDE = 'R' or by A*P**T if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J REAL CTEMP, STEMP, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P**T * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of SLASR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slasrt.f000066400000000000000000000173001522610125300262630ustar00rootroot00000000000000*> \brief \b SLASRT sorts numbers in increasing or decreasing order. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASRT( ID, N, D, INFO ) * * .. Scalar Arguments .. * CHARACTER ID * INTEGER INFO, N * .. * .. Array Arguments .. * REAL D( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Sort the numbers in D in increasing order (if ID = 'I') or *> in decreasing order (if ID = 'D' ). *> *> Use Quick Sort, reverting to Insertion sort on arrays of *> size <= 20. Dimension of STACK limits N to about 2**32. *> \endverbatim * * Arguments: * ========== * *> \param[in] ID *> \verbatim *> ID is CHARACTER*1 *> = 'I': sort D in increasing order; *> = 'D': sort D in decreasing order. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The length of the array D. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is REAL array, dimension (N) *> On entry, the array to be sorted. *> On exit, D has been sorted into increasing order *> (D(1) <= ... <= D(N) ) or into decreasing order *> (D(1) >= ... >= D(N) ), depending on ID. *> \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 June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SLASRT( ID, N, D, 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..-- * June 2016 * * .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N * .. * .. Array Arguments .. REAL D( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER SELECT PARAMETER ( SELECT = 20 ) * .. * .. Local Scalars .. INTEGER DIR, ENDD, I, J, START, STKPNT REAL D1, D2, D3, DMNMX, TMP * .. * .. Local Arrays .. INTEGER STACK( 2, 32 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 DIR = -1 IF( LSAME( ID, 'D' ) ) THEN DIR = 0 ELSE IF( LSAME( ID, 'I' ) ) THEN DIR = 1 END IF IF( DIR.EQ.-1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLASRT', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * STKPNT = 1 STACK( 1, 1 ) = 1 STACK( 2, 1 ) = N 10 CONTINUE START = STACK( 1, STKPNT ) ENDD = STACK( 2, STKPNT ) STKPNT = STKPNT - 1 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN * * Do Insertion sort on D( START:ENDD ) * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * DO 30 I = START + 1, ENDD DO 20 J = I, START + 1, -1 IF( D( J ).GT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 30 END IF 20 CONTINUE 30 CONTINUE * ELSE * * Sort into increasing order * DO 50 I = START + 1, ENDD DO 40 J = I, START + 1, -1 IF( D( J ).LT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 50 END IF 40 CONTINUE 50 CONTINUE * END IF * ELSE IF( ENDD-START.GT.SELECT ) THEN * * Partition D( START:ENDD ) and stack parts, largest one first * * Choose partition entry as median of 3 * D1 = D( START ) D2 = D( ENDD ) I = ( START+ENDD ) / 2 D3 = D( I ) IF( D1.LT.D2 ) THEN IF( D3.LT.D1 ) THEN DMNMX = D1 ELSE IF( D3.LT.D2 ) THEN DMNMX = D3 ELSE DMNMX = D2 END IF ELSE IF( D3.LT.D2 ) THEN DMNMX = D2 ELSE IF( D3.LT.D1 ) THEN DMNMX = D3 ELSE DMNMX = D1 END IF END IF * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * I = START - 1 J = ENDD + 1 60 CONTINUE 70 CONTINUE J = J - 1 IF( D( J ).LT.DMNMX ) $ GO TO 70 80 CONTINUE I = I + 1 IF( D( I ).GT.DMNMX ) $ GO TO 80 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 60 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF ELSE * * Sort into increasing order * I = START - 1 J = ENDD + 1 90 CONTINUE 100 CONTINUE J = J - 1 IF( D( J ).GT.DMNMX ) $ GO TO 100 110 CONTINUE I = I + 1 IF( D( I ).LT.DMNMX ) $ GO TO 110 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 90 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF END IF END IF IF( STKPNT.GT.0 ) $ GO TO 10 RETURN * * End of SLASRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slassq.f000066400000000000000000000103151522610125300262600ustar00rootroot00000000000000*> \brief \b SLASSQ updates a sum of squares represented in scaled form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASSQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) * * .. Scalar Arguments .. * INTEGER INCX, N * REAL SCALE, SUMSQ * .. * .. Array Arguments .. * REAL X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLASSQ returns the values scl and smsq such that *> *> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, *> *> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is *> assumed to be non-negative and scl returns the value *> *> scl = max( scale, abs( x( i ) ) ). *> *> scale and sumsq must be supplied in SCALE and SUMSQ and *> scl and smsq are overwritten on SCALE and SUMSQ respectively. *> *> The routine makes only one pass through the vector x. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements to be used from the vector X. *> \endverbatim *> *> \param[in] X *> \verbatim *> X is REAL array, dimension (N) *> The vector for which a scaled sum of squares is computed. *> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of the vector X. *> INCX > 0. *> \endverbatim *> *> \param[in,out] SCALE *> \verbatim *> SCALE is REAL *> On entry, the value scale in the equation above. *> On exit, SCALE is overwritten with scl , the scaling factor *> for the sum of squares. *> \endverbatim *> *> \param[in,out] SUMSQ *> \verbatim *> SUMSQ is REAL *> On entry, the value sumsq in the equation above. *> On exit, SUMSQ is overwritten with smsq , the basic sum of *> squares from which scl has been factored out. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N REAL SCALE, SUMSQ * .. * .. Array Arguments .. REAL X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER IX REAL ABSXI * .. * .. External Functions .. LOGICAL SISNAN EXTERNAL SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX ABSXI = ABS( X( IX ) ) IF( ABSXI.GT.ZERO.OR.SISNAN( ABSXI ) ) THEN IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * End of SLASSQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slasv2.f000066400000000000000000000202751522610125300261720ustar00rootroot00000000000000*> \brief \b SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SLASV2 computes the singular value decomposition of a 2-by-2 *> triangular matrix *> [ F G ] *> [ 0 H ]. *> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the *> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and *> right singular vectors for abs(SSMAX), giving the decomposition *> *> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] *> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is REAL *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is REAL *> The (1,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is REAL *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] SSMIN *> \verbatim *> SSMIN is REAL *> abs(SSMIN) is the smaller singular value. *> \endverbatim *> *> \param[out] SSMAX *> \verbatim *> SSMAX is REAL *> abs(SSMAX) is the larger singular value. *> \endverbatim *> *> \param[out] SNL *> \verbatim *> SNL is REAL *> \endverbatim *> *> \param[out] CSL *> \verbatim *> CSL is REAL *> The vector (CSL, SNL) is a unit left singular vector for the *> singular value abs(SSMAX). *> \endverbatim *> *> \param[out] SNR *> \verbatim *> SNR is REAL *> \endverbatim *> *> \param[out] CSR *> \verbatim *> CSR is REAL *> The vector (CSR, SNR) is a unit right singular vector for the *> singular value abs(SSMAX). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Any input parameter may be aliased with any output parameter. *> *> Barring over/underflow and assuming a guard digit in subtraction, all *> output quantities are correct to within a few units in the last *> place (ulps). *> *> In IEEE arithmetic, the code works correctly if one matrix element is *> infinite. *> *> Overflow will not occur unless the largest singular value itself *> overflows or is within a few ulps of overflow. (On machines with *> partial overflow, like the Cray, overflow may occur if the largest *> singular value is within a factor of 2 of overflow.) *> *> Underflow is harmless if underflow is gradual. Otherwise, results *> may correspond to a matrix modified by perturbations of size near *> the underflow threshold. *> \endverbatim *> * ===================================================================== SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * * -- LAPACK auxiliary routine (version 3.7.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 .. REAL CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) REAL FOUR PARAMETER ( FOUR = 4.0E0 ) * .. * .. Local Scalars .. LOGICAL GASMAL, SWAP INTEGER PMAX REAL A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Executable Statements .. * FT = F FA = ABS( FT ) HT = H HA = ABS( H ) * * PMAX points to the maximum absolute element of matrix * PMAX = 1 if F largest in absolute values * PMAX = 2 if G largest in absolute values * PMAX = 3 if H largest in absolute values * PMAX = 1 SWAP = ( HA.GT.FA ) IF( SWAP ) THEN PMAX = 3 TEMP = FT FT = HT HT = TEMP TEMP = FA FA = HA HA = TEMP * * Now FA .ge. HA * END IF GT = G GA = ABS( GT ) IF( GA.EQ.ZERO ) THEN * * Diagonal matrix * SSMIN = HA SSMAX = FA CLT = ONE CRT = ONE SLT = ZERO SRT = ZERO ELSE GASMAL = .TRUE. IF( GA.GT.FA ) THEN PMAX = 2 IF( ( FA / GA ).LT.SLAMCH( 'EPS' ) ) THEN * * Case of very large GA * GASMAL = .FALSE. SSMAX = GA IF( HA.GT.ONE ) THEN SSMIN = FA / ( GA / HA ) ELSE SSMIN = ( FA / GA )*HA END IF CLT = ONE SLT = HT / GT SRT = ONE CRT = FT / GT END IF END IF IF( GASMAL ) THEN * * Normal case * D = FA - HA IF( D.EQ.FA ) THEN * * Copes with infinite F or H * L = ONE ELSE L = D / FA END IF * * Note that 0 .le. L .le. 1 * M = GT / FT * * Note that abs(M) .le. 1/macheps * T = TWO - L * * Note that T .ge. 1 * MM = M*M TT = T*T S = SQRT( TT+MM ) * * Note that 1 .le. S .le. 1 + 1/macheps * IF( L.EQ.ZERO ) THEN R = ABS( M ) ELSE R = SQRT( L*L+MM ) END IF * * Note that 0 .le. R .le. 1 + 1/macheps * A = HALF*( S+R ) * * Note that 1 .le. A .le. 1 + abs(M) * SSMIN = HA / A SSMAX = FA*A IF( MM.EQ.ZERO ) THEN * * Note that M is very tiny * IF( L.EQ.ZERO ) THEN T = SIGN( TWO, FT )*SIGN( ONE, GT ) ELSE T = GT / SIGN( D, FT ) + M / T END IF ELSE T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) END IF L = SQRT( T*T+FOUR ) CRT = TWO / L SRT = T / L CLT = ( CRT+SRT*M ) / A SLT = ( HT / FT )*SRT / A END IF END IF IF( SWAP ) THEN CSL = SRT SNL = CRT CSR = SLT SNR = CLT ELSE CSL = CLT SNL = SLT CSR = CRT SNR = SRT END IF * * Correct signs of SSMAX and SSMIN * IF( PMAX.EQ.1 ) $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) IF( PMAX.EQ.2 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) IF( PMAX.EQ.3 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) SSMAX = SIGN( SSMAX, TSIGN ) SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) RETURN * * End of SLASV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slaswp.f000066400000000000000000000117101522610125300262630ustar00rootroot00000000000000*> \brief \b SLASWP performs a series of row interchanges on a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASWP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLASWP performs a series of row interchanges on the matrix A. *> One row interchange is initiated for each of rows K1 through K2 of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the matrix of column dimension N to which the row *> interchanges will be applied. *> On exit, the permuted matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> \endverbatim *> *> \param[in] K1 *> \verbatim *> K1 is INTEGER *> The first element of IPIV for which a row interchange will *> be done. *> \endverbatim *> *> \param[in] K2 *> \verbatim *> K2 is INTEGER *> (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 (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 *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of IPIV. If IPIV *> is negative, the pivots are applied in reverse order. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by *> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA *> \endverbatim *> * ===================================================================== SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 REAL TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of SLASWP * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slasy2.f000066400000000000000000000342341522610125300261750ustar00rootroot00000000000000*> \brief \b SLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLASY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL SCALE, XNORM * .. * .. Array Arguments .. * REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in *> *> op(TL)*X + ISGN*X*op(TR) = SCALE*B, *> *> where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or *> -1. op(T) = T or T**T, where T**T denotes the transpose of T. *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRANL *> \verbatim *> LTRANL is LOGICAL *> On entry, LTRANL specifies the op(TL): *> = .FALSE., op(TL) = TL, *> = .TRUE., op(TL) = TL**T. *> \endverbatim *> *> \param[in] LTRANR *> \verbatim *> LTRANR is LOGICAL *> On entry, LTRANR specifies the op(TR): *> = .FALSE., op(TR) = TR, *> = .TRUE., op(TR) = TR**T. *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> On entry, ISGN specifies the sign of the equation *> as described before. ISGN may only be 1 or -1. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> On entry, N1 specifies the order of matrix TL. *> N1 may only be 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> On entry, N2 specifies the order of matrix TR. *> N2 may only be 0, 1 or 2. *> \endverbatim *> *> \param[in] TL *> \verbatim *> TL is REAL array, dimension (LDTL,2) *> On entry, TL contains an N1 by N1 matrix. *> \endverbatim *> *> \param[in] LDTL *> \verbatim *> LDTL is INTEGER *> The leading dimension of the matrix TL. LDTL >= max(1,N1). *> \endverbatim *> *> \param[in] TR *> \verbatim *> TR is REAL array, dimension (LDTR,2) *> On entry, TR contains an N2 by N2 matrix. *> \endverbatim *> *> \param[in] LDTR *> \verbatim *> LDTR is INTEGER *> The leading dimension of the matrix TR. LDTR >= max(1,N2). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB,2) *> On entry, the N1 by N2 matrix B contains the right-hand *> side of the equation. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1,N1). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit, SCALE contains the scale factor. SCALE is chosen *> less than or equal to 1 to prevent the solution overflowing. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is REAL array, dimension (LDX,2) *> On exit, X contains the N1 by N2 solution. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the matrix X. LDX >= max(1,N1). *> \endverbatim *> *> \param[out] XNORM *> \verbatim *> XNORM is REAL *> On exit, XNORM is the infinity-norm of the solution. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, INFO is set to *> 0: successful exit. *> 1: TL and TR have too close eigenvalues, so TL or *> TR is perturbed to get a nonsingular equation. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realSYauxiliary * * ===================================================================== SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 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 .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 REAL SCALE, XNORM * .. * .. Array Arguments .. REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL TWO, HALF, EIGHT PARAMETER ( TWO = 2.0E+0, HALF = 0.5E+0, EIGHT = 8.0E+0 ) * .. * .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K REAL BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX * .. * .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) REAL BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) * .. * .. External Functions .. INTEGER ISAMAX REAL SLAMCH EXTERNAL ISAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL SCOPY, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / * .. * .. Executable Statements .. * * Do not check the input parameters for errors * INFO = 0 * * Quick return if possible * IF( N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS SGN = ISGN * K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K * * 1 by 1: TL11*X + SGN*X*TR11 = B11 * 10 CONTINUE TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF * SCALE = ONE GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN * * 1 by 2: * TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] * [TR21 TR22] * 20 CONTINUE * SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) IF( LTRANR ) THEN TMP( 2 ) = SGN*TR( 2, 1 ) TMP( 3 ) = SGN*TR( 1, 2 ) ELSE TMP( 2 ) = SGN*TR( 1, 2 ) TMP( 3 ) = SGN*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 * * 2 by 1: * op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] * [TL21 TL22] [X21] [X21] [B21] * 30 CONTINUE SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) IF( LTRANL ) THEN TMP( 2 ) = TL( 1, 2 ) TMP( 3 ) = TL( 2, 1 ) ELSE TMP( 2 ) = TL( 2, 1 ) TMP( 3 ) = TL( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE * * Solve 2 by 2 system using complete pivoting. * Set pivots less than SMIN to SMIN. * IPIV = ISAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF SCALE = ONE IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) END IF RETURN * * 2 by 2: * op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] * [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] * * Solve equivalent 4 by 4 system using complete pivoting. * Set pivots less than SMIN to SMIN. * 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) SMIN = MAX( EPS*SMIN, SMLNUM ) BTMP( 1 ) = ZERO CALL SCOPY( 16, BTMP, 0, T16, 1 ) T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) IF( LTRANL ) THEN T16( 1, 2 ) = TL( 2, 1 ) T16( 2, 1 ) = TL( 1, 2 ) T16( 3, 4 ) = TL( 2, 1 ) T16( 4, 3 ) = TL( 1, 2 ) ELSE T16( 1, 2 ) = TL( 1, 2 ) T16( 2, 1 ) = TL( 2, 1 ) T16( 3, 4 ) = TL( 1, 2 ) T16( 4, 3 ) = TL( 2, 1 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = SGN*TR( 1, 2 ) T16( 2, 4 ) = SGN*TR( 1, 2 ) T16( 3, 1 ) = SGN*TR( 2, 1 ) T16( 4, 2 ) = SGN*TR( 2, 1 ) ELSE T16( 1, 3 ) = SGN*TR( 2, 1 ) T16( 2, 4 ) = SGN*TR( 2, 1 ) T16( 3, 1 ) = SGN*TR( 1, 2 ) T16( 4, 2 ) = SGN*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) * * Perform elimination * DO 100 I = 1, 3 XMAX = ZERO DO 70 IP = I, 4 DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE 70 CONTINUE IF( IPSV.NE.I ) THEN CALL SSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL SSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE 90 CONTINUE 100 CONTINUE 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. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE 120 CONTINUE DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) RETURN * * End of SLASY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slatdf.f000066400000000000000000000244701522610125300262360ustar00rootroot00000000000000*> \brief \b SLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLATDF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) * * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * REAL RDSCAL, RDSUM * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * REAL RHS( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLATDF uses the LU factorization of the n-by-n matrix Z computed by *> SGETC2 and computes a contribution to the reciprocal Dif-estimate *> by solving Z * x = b for x, and choosing the r.h.s. b such that *> the norm of x is as large as possible. On entry RHS = b holds the *> contribution from earlier solved sub-systems, and on return RHS = x. *> *> The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q, *> where P and Q are permutation matrices. L is lower triangular with *> unit diagonal elements and U is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> IJOB = 2: First compute an approximative null-vector e *> of Z using SGECON, e is normalized and solve for *> 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 chosen as either +1 or -1 (Default). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Z. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is REAL array, dimension (LDZ, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix Z computed by SGETC2: Z = P * L * U * Q *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is REAL array, dimension N. *> On entry, RHS contains contributions from other subsystems. *> On exit, RHS contains the solution of the subsystem with *> entries acoording to the value of IJOB (see above). *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is REAL *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by STGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is REAL *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when STGSY2 is called by *> STGSYL. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> This routine is a further developed implementation of algorithm *> BSOLVE in [1] using complete pivoting in the LU factorization. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> *> [1] Bo Kagstrom and Lars Westin, *> Generalized Schur Methods with Condition Estimators for *> Solving the Generalized Sylvester Equation, IEEE Transactions *> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. *> *> [2] Peter Poromaa, *> On Efficient and Robust Estimators for the Separation *> between two Regular Matrix Pairs with Applications in *> Condition Estimation. Report IMINF-95.05, Departement of *> Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. *> \endverbatim *> * ===================================================================== SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER IJOB, LDZ, N REAL RDSCAL, RDSUM * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) REAL RHS( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXDIM PARAMETER ( MAXDIM = 8 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J, K REAL BM, BP, PMONE, SMINU, SPLUS, TEMP * .. * .. Local Arrays .. INTEGER IWORK( MAXDIM ) REAL WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SGECON, SGESC2, SLASSQ, SLASWP, $ SSCAL * .. * .. External Functions .. REAL SASUM, SDOT EXTERNAL SASUM, SDOT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( IJOB.NE.2 ) THEN * * Apply permutations IPIV to RHS * CALL SLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) * * Solve for L-part choosing RHS either to +1 or -1. * PMONE = -ONE * DO 10 J = 1, N - 1 BP = RHS( J ) + ONE BM = RHS( J ) - ONE SPLUS = ONE * * Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and * SMIN computed more efficiently than in BSOLVE [1]. * SPLUS = SPLUS + SDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 ) SMINU = SDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) SPLUS = SPLUS*RHS( J ) IF( SPLUS.GT.SMINU ) THEN RHS( J ) = BP ELSE IF( SMINU.GT.SPLUS ) THEN RHS( J ) = BM ELSE * * In this case the updating sums are equal and we can * choose RHS(J) +1 or -1. The first time this happens * we choose -1, thereafter +1. This is a simple way to * get good estimates of matrices like Byers well-known * example (see [1]). (Not done in BSOLVE.) * RHS( J ) = RHS( J ) + PMONE PMONE = ONE END IF * * Compute the remaining r.h.s. * TEMP = -RHS( J ) CALL SAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) * 10 CONTINUE * * Solve for U-part, look-ahead for RHS(N) = +-1. This is not done * in BSOLVE and will hopefully give us a better estimate because * any ill-conditioning of the original matrix is transfered to U * and not to L. U(N, N) is an approximation to sigma_min(LU). * CALL SCOPY( N-1, RHS, 1, XP, 1 ) XP( N ) = RHS( N ) + ONE RHS( N ) = RHS( N ) - ONE SPLUS = ZERO SMINU = ZERO DO 30 I = N, 1, -1 TEMP = ONE / Z( I, I ) XP( I ) = XP( I )*TEMP RHS( I ) = RHS( I )*TEMP DO 20 K = I + 1, N XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP ) RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) 20 CONTINUE SPLUS = SPLUS + ABS( XP( I ) ) SMINU = SMINU + ABS( RHS( I ) ) 30 CONTINUE IF( SPLUS.GT.SMINU ) $ CALL SCOPY( N, XP, 1, RHS, 1 ) * * Apply the permutations JPIV to the computed solution (RHS) * CALL SLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) * * Compute the sum of squares * CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM ) * ELSE * * IJOB = 2, Compute approximate nullvector XM of Z * CALL SGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO ) CALL SCOPY( N, WORK( N+1 ), 1, XM, 1 ) * * Compute RHS * CALL SLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) TEMP = ONE / SQRT( SDOT( N, XM, 1, XM, 1 ) ) CALL SSCAL( N, TEMP, XM, 1 ) CALL SCOPY( N, XM, 1, XP, 1 ) CALL SAXPY( N, ONE, RHS, 1, XP, 1 ) CALL SAXPY( N, -ONE, XM, 1, RHS, 1 ) CALL SGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP ) CALL SGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP ) IF( SASUM( N, XP, 1 ).GT.SASUM( N, RHS, 1 ) ) $ CALL SCOPY( N, XP, 1, RHS, 1 ) * * Compute the sum of squares * CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM ) * END IF * RETURN * * End of SLATDF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slatrs.f000066400000000000000000000572261522610125300262760ustar00rootroot00000000000000*> \brief \b SLATRS solves a triangular system of equations with the scale factor set to prevent overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SLATRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL SCALE * .. * .. Array Arguments .. * REAL A( LDA, * ), CNORM( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SLATRS solves one of the triangular systems *> *> A *x = s*b or A**T*x = s*b *> *> with scaling to prevent overflow. Here A is an upper or lower *> triangular matrix, A**T denotes the transpose of A, x and b are *> n-element vectors, and s is a scaling factor, usually less than *> or equal to 1, chosen so that the components of x will be less than *> the overflow threshold. If the unscaled problem will not cause *> overflow, the Level 2 BLAS routine STRSV is called. If the matrix A *> is singular (A(j,j) = 0 for some j), then s is set to 0 and a *> non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T* x = s*b (Transpose) *> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \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) *> The triangular matrix A. If UPLO = 'U', the leading n by n *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading n by n lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max (1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is REAL array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> The scaling factor s for the triangular system *> A * x = s*b or A**T* x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is REAL array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-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 realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, STRSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic *> algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N REAL SCALE * .. * .. Array Arguments .. REAL A( LDA, * ), CNORM( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER ISAMAX REAL SASUM, SDOT, SLAMCH EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH * .. * .. External Subroutines .. EXTERNAL SAXPY, SSCAL, STRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = SASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = SASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM. * IMAX = ISAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM ) THEN TSCAL = ONE ELSE TSCAL = ONE / ( SMLNUM*TMAX ) CALL SSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine STRSV can be used. * J = ISAMAX( N, X, 1 ) XMAX = ABS( X( J ) ) XBND = XMAX IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 50 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 30 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * M(j) = G(j-1) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 30 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 40 CONTINUE END IF 50 CONTINUE * ELSE * * Compute the growth in A**T * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 80 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 60 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) 60 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 70 CONTINUE END IF 80 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = BIGNUM / XMAX CALL SSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 100 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 95 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL SSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL SSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 90 I = 1, N X( I ) = ZERO 90 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 95 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL SSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL SSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL SAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = ISAMAX( J-1, X, 1 ) XMAX = ABS( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL SAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + ISAMAX( N-J, X( J+1 ), 1 ) XMAX = ABS( X( I ) ) END IF END IF 100 CONTINUE * ELSE * * Solve A**T * x = b * DO 140 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = ABS( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = ABS( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = USCAL / TJJS END IF IF( REC.LT.ONE ) THEN CALL SSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * SUMJ = ZERO IF( USCAL.EQ.ONE ) THEN * * If the scaling needed for A in the dot product is 1, * call SDOT to perform the dot product. * IF( UPPER ) THEN SUMJ = SDOT( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN SUMJ = SDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 110 I = 1, J - 1 SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 110 CONTINUE ELSE IF( J.LT.N ) THEN DO 120 I = J + 1, N SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 120 CONTINUE END IF END IF * IF( USCAL.EQ.TSCAL ) THEN * * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - SUMJ XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 135 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL SSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL SSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A**T*x = 0. * DO 130 I = 1, N X( I ) = ZERO 130 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 135 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - sumj if the dot * product has already been divided by 1/A(j,j). * X( J ) = X( J ) / TJJS - SUMJ END IF XMAX = MAX( XMAX, ABS( X( J ) ) ) 140 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL SSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of SLATRS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/slatsqr.f000066400000000000000000000171121522610125300264450ustar00rootroot00000000000000*> \brief \b SLATSQR * * 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 *> a real M-by-N matrix A for M >= N: *> *> A = Q * ( R ), *> ( 0 ) *> *> where: *> *> Q is a M-by-M orthogonal matrix, stored on exit in an implicit *> form in the elements below the digonal of the array A and in *> the elemenst of the array T; *> *> R is an upper-triangular N-by-N matrix, stored on exit in *> the elements on and above the diagonal of the array A. *> *> 0 is a (M-N)-by-N zero matrix, and is not stored. *> *> \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.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- * November 2019 * * .. Scalar Arguments .. INTEGER 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorg2r.f000066400000000000000000000121521522610125300261710ustar00rootroot00000000000000*> \brief \b SORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORG2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SORG2R generates an m by n real matrix Q with orthonormal columns, *> which is defined as the first n columns of a product of k elementary *> reflectors of order m *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by SGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by SGEQRF in the first k columns of its array *> argument A. *> On exit, the m-by-n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGEQRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has 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 realOTHERcomputational * * ===================================================================== SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, 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, K, LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL SLARF, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL SSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of SORG2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorghr.f000066400000000000000000000146021522610125300262610ustar00rootroot00000000000000*> \brief \b SORGHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORGHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SORGHR generates a real orthogonal matrix Q which is defined as the *> product of IHI-ILO elementary reflectors of order N, as returned by *> SGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of SGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by SGEHRD. *> On exit, the N-by-N orthogonal matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGEHRD. *> \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. LWORK >= IHI-ILO. *> For optimum performance LWORK >= (IHI-ILO)*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 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL SORGQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'SORGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL SORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of SORGHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorgqr.f000066400000000000000000000175421522610125300263000ustar00rootroot00000000000000*> \brief \b SORGQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORGQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SORGQR generates an M-by-N real matrix Q with orthonormal columns, *> which is defined as the first N columns of a product of K elementary *> reflectors of order M *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by SGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by SGEQRF in the first k columns of its array *> argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGEQRF. *> \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. LWORK >= max(1,N). *> For optimum performance LWORK >= 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 has 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 realOTHERcomputational * * ===================================================================== SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, 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, K, LDA, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL SLARFB, SLARFT, SORG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'SORGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'SORGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'SORGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL SORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL SLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL SLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL SORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of SORGQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorgr2.f000066400000000000000000000122551522610125300261750ustar00rootroot00000000000000*> \brief \b SORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORGR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> SORGR2 generates an m by n real matrix Q with orthonormal rows, *> which is defined as the last m rows of a product of k elementary *> reflectors of order n *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by SGERQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the (m-k+i)-th row must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by SGERQF in the last k rows of its array argument *> A. *> On exit, the m by n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGERQF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has 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 realOTHERcomputational * * ===================================================================== SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, 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, K, LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL SLARF, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORGR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows 1:m-k to rows of the unit matrix * DO 20 J = 1, N DO 10 L = 1, M - K A( L, J ) = ZERO 10 CONTINUE IF( J.GT.N-M .AND. J.LE.N-K ) $ A( M-N+J, J ) = ONE 20 CONTINUE END IF * DO 40 I = 1, K II = M - K + I * * Apply H(i) to A(1:m-k+i,1:n-k+i) from the right * A( II, N-M+II ) = ONE CALL SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ), $ A, LDA, WORK ) CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - TAU( I ) * * Set A(m-k+i,n-k+i+1:n) to zero * DO 30 L = N - M + II + 1, N A( II, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of SORGR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorgtsqr.f000066400000000000000000000217471522610125300266510ustar00rootroot00000000000000*> \brief \b SORGTSQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORGTSQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> * Definition: * =========== * * SUBROUTINE SORGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, * $ INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. * REAL A( LDA, * ), T( LDT, * ), WORK( * ) * .. * *> \par Purpose: * ============= *> *> \verbatim *> *> SORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, *> which are the first N columns of a product of real orthogonal *> matrices of order M which are returned by SLATSQR *> *> Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). *> *> See the documentation for SLATSQR. *> \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 used by SLATSQR to return *> arrays A and T. MB > N. *> (Note that if MB > M, then M is used instead of MB *> as the row block size). *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The column block size used by SLATSQR to return *> arrays A and T. NB >= 1. *> (Note that if NB > N, then N is used instead of NB *> as the column block size). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is REAL array, dimension (LDA,N) *> *> On entry: *> *> The elements on and above the diagonal are not accessed. *> The elements below the diagonal represent the unit *> lower-trapezoidal blocked matrix V computed by SLATSQR *> that defines the input matrices Q_in(k) (ones on the *> diagonal are not stored) (same format as the output A *> below the diagonal in SLATSQR). *> *> On exit: *> *> The array A contains an M-by-N orthonormal matrix Q_out, *> i.e the columns of A are orthogonal unit vectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] T *> \verbatim *> T is REAL array, *> dimension (LDT, N * NIRB) *> where NIRB = Number_of_input_row_blocks *> = MAX( 1, CEIL((M-N)/(MB-N)) ) *> Let NICB = Number_of_input_col_blocks *> = CEIL(N/NB) *> *> The upper-triangular block reflectors used to define the *> input matrices Q_in(k), k=(1:NIRB*NICB). The block *> reflectors are stored in compact form in NIRB block *> reflector sequences. Each of NIRB block reflector sequences *> is stored in a larger NB-by-N column block of T and consists *> of NICB smaller NB-by-NB upper-triangular column blocks. *> (same format as the output T in SLATSQR). *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= max(1,min(NB1,N)). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> (workspace) REAL array, dimension (MAX(2,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> The dimension of the array WORK. LWORK >= (M+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. * *> \date November 2019 * *> \ingroup singleOTHERcomputational * *> \par Contributors: * ================== *> *> \verbatim *> *> November 2019, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> *> \endverbatim * * ===================================================================== SUBROUTINE SORGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, $ INFO ) IMPLICIT NONE * * -- LAPACK computational routine (version 3.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2019 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. REAL A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER IINFO, LDC, LWORKOPT, LC, LW, NBLOCAL, J * .. * .. External Subroutines .. EXTERNAL SCOPY, SLAMTSQR, SLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC REAL, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * LQUERY = LWORK.EQ.-1 INFO = 0 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 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDT.LT.MAX( 1, MIN( NB, N ) ) ) THEN INFO = -8 ELSE * * Test the input LWORK for the dimension of the array WORK. * This workspace is used to store array C(LDC, N) and WORK(LWORK) * in the call to DLAMTSQR. See the documentation for DLAMTSQR. * IF( LWORK.LT.2 .AND. (.NOT.LQUERY) ) THEN INFO = -10 ELSE * * Set block size for column blocks * NBLOCAL = MIN( NB, N ) * * LWORK = -1, then set the size for the array C(LDC,N) * in DLAMTSQR call and set the optimal size of the work array * WORK(LWORK) in DLAMTSQR call. * LDC = M LC = LDC*N LW = N * NBLOCAL * LWORKOPT = LC+LW * IF( ( LWORK.LT.MAX( 1, LWORKOPT ) ).AND.(.NOT.LQUERY) ) THEN INFO = -10 END IF END IF * END IF * * Handle error in the input parameters and return workspace query. * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORGTSQR', -INFO ) RETURN ELSE IF ( LQUERY ) THEN WORK( 1 ) = REAL( LWORKOPT ) RETURN END IF * * Quick return if possible * IF( MIN( M, N ).EQ.0 ) THEN WORK( 1 ) = REAL( LWORKOPT ) RETURN END IF * * (1) Form explicitly the tall-skinny M-by-N left submatrix Q1_in * of M-by-M orthogonal matrix Q_in, which is implicitly stored in * the subdiagonal part of input array A and in the input array T. * Perform by the following operation using the routine DLAMTSQR. * * Q1_in = Q_in * ( I ), where I is a N-by-N identity matrix, * ( 0 ) 0 is a (M-N)-by-N zero matrix. * * (1a) Form M-by-N matrix in the array WORK(1:LDC*N) with ones * on the diagonal and zeros elsewhere. * CALL SLASET( 'F', M, N, ZERO, ONE, WORK, LDC ) * * (1b) On input, WORK(1:LDC*N) stores ( I ); * ( 0 ) * * On output, WORK(1:LDC*N) stores Q1_in. * CALL SLAMTSQR( 'L', 'N', M, N, N, MB, NBLOCAL, A, LDA, T, LDT, $ WORK, LDC, WORK( LC+1 ), LW, IINFO ) * * (2) Copy the result from the part of the work array (1:M,1:N) * with the leading dimension LDC that starts at WORK(1) into * the output array A(1:M,1:N) column-by-column. * DO J = 1, N CALL SCOPY( M, WORK( (J-1)*LDC + 1 ), 1, A( 1, J ), 1 ) END DO * WORK( 1 ) = REAL( LWORKOPT ) RETURN * * End of SORGTSQR * ENDqrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorm2r.f000066400000000000000000000162401522610125300262010ustar00rootroot00000000000000*> \brief \b SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORM2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SORM2R overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by SGEQRF. 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': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \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] A *> \verbatim *> A is REAL array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> SGEQRF in the first k columns of its array argument A. *> A is modified by the routine but restored on exit. *> \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] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGEQRF. *> \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 *> WORK is REAL array, dimension *> (N) if SIDE = 'L', *> (M) 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 realOTHERcomputational * * ===================================================================== SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of SORM2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sormbr.f000066400000000000000000000252151522610125300262630ustar00rootroot00000000000000*> \brief \b SORMBR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORMBR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> If VECT = 'Q', SORMBR 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 *> *> If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': P * C C * P *> TRANS = 'T': P**T * C C * P**T *> *> Here Q and P**T are the orthogonal matrices determined by SGEBRD when *> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and *> P**T are defined as products of elementary reflectors H(i) and G(i) *> respectively. *> *> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the *> order of the orthogonal matrix Q or P**T that is applied. *> *> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: *> if nq >= k, Q = H(1) H(2) . . . H(k); *> if nq < k, Q = H(1) H(2) . . . H(nq-1). *> *> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: *> if k < nq, P = G(1) G(2) . . . G(k); *> if k >= nq, P = G(1) G(2) . . . G(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'Q': apply Q or Q**T; *> = 'P': apply P or P**T. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q, Q**T, P or P**T from the Left; *> = 'R': apply Q, Q**T, P or P**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q or P; *> = 'T': Transpose, apply Q**T or P**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 *> If VECT = 'Q', the number of columns in the original *> matrix reduced by SGEBRD. *> If VECT = 'P', the number of rows in the original *> matrix reduced by SGEBRD. *> K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension *> (LDA,min(nq,K)) if VECT = 'Q' *> (LDA,nq) if VECT = 'P' *> The vectors which define the elementary reflectors H(i) and *> G(i), whose products determine the matrices Q and P, as *> returned by SGEBRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If VECT = 'Q', LDA >= max(1,nq); *> if VECT = 'P', LDA >= max(1,min(nq,K)). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (min(nq,K)) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i) or G(i) which determines Q or P, as returned *> by SGEBRD in the array argument TAUQ or TAUP. *> \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 *> or P*C or P**T*C or C*P or C*P**T. *> \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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', 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 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, 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, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL SORMLQ, SORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( K.LT.0 ) THEN INFO = -6 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) $ THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M-1, N, M-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 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * WORK( 1 ) = 1 IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to SGEBRD with nq >= k * CALL SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to SGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL SORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to SGEBRD with nq > k * CALL SORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to SGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL SORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of SORMBR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sormhr.f000066400000000000000000000202621522610125300262660ustar00rootroot00000000000000*> \brief \b SORMHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORMHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SORMHR 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 of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> IHI-ILO elementary reflectors, as returned by SGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \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 C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of SGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and *> ILO = 1 and IHI = 0, if M = 0; *> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and *> ILO = 1 and IHI = 0, if N = 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension *> (LDA,M) if SIDE = 'L' *> (LDA,N) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by SGEHRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGEHRD. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', 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 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL SORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LEFT = LSAME( SIDE, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) $ THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN INFO = -5 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, NH, N, NH, -1 ) ELSE NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, NH, NH, -1 ) END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORMHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = NH NI = N I1 = ILO + 1 I2 = 1 ELSE MI = M NI = NH I1 = 1 I2 = ILO + 1 END IF * CALL SORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) * WORK( 1 ) = LWKOPT RETURN * * End of SORMHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sorml2.f000066400000000000000000000162731522610125300262010ustar00rootroot00000000000000*> \brief \b SORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORML2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SORML2 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by SGELQF. 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': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \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] A *> \verbatim *> A is REAL array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> SGELQF in the first k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGELQF. *> \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 *> WORK is REAL array, dimension *> (N) if SIDE = 'L', *> (M) 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 realOTHERcomputational * * ===================================================================== SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORML2', -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 ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), $ C( IC, JC ), LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of SORML2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sormlq.f000066400000000000000000000225111522610125300262700ustar00rootroot00000000000000*> \brief \b SORMLQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORMLQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SORMLQ 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(k) . . . H(2) H(1) *> *> as returned by SGELQF. 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; *> = 'T': 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] A *> \verbatim *> A is REAL array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> SGELQF 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. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGELQF. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL SLARFB, SLARFT, SORML2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'SORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'SORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL SLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL SLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, $ A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of SORMLQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sormqr.f000066400000000000000000000222431522610125300263000ustar00rootroot00000000000000*> \brief \b SORMQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORMQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SORMQR 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) *> *> as returned by SGEQRF. 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; *> = 'T': 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] A *> \verbatim *> A is REAL array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> SGEQRF 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] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGEQRF. *> \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 *> 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL SLARFB, SLARFT, SORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'SORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL SLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL SLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of SORMQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/sormr2.f000066400000000000000000000161671522610125300262110ustar00rootroot00000000000000*> \brief \b SORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORMR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SORMR2 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by SGERQF. 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': apply Q (No transpose) *> = 'T': apply Q' (Transpose) *> \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] A *> \verbatim *> A is REAL array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> SGERQF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is REAL array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by SGERQF. *> \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 *> WORK is REAL array, dimension *> (N) if SIDE = 'L', *> (M) 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 realOTHERcomputational * * ===================================================================== SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORMR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) * AII = A( I, NQ-K+I ) A( I, NQ-K+I ) = ONE CALL SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, $ WORK ) A( I, NQ-K+I ) = AII 10 CONTINUE RETURN * * End of SORMR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ssteqr.f000066400000000000000000000362161522610125300263030ustar00rootroot00000000000000*> \brief \b SSTEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SSTEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> SSTEQR computes all eigenvalues and, optionally, eigenvectors of a *> symmetric tridiagonal matrix using the implicit QL or QR method. *> The eigenvectors of a full or band symmetric matrix can also be found *> if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to *> tridiagonal form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'V': Compute eigenvalues and eigenvectors of the original *> symmetric matrix. On entry, Z must contain the *> orthogonal matrix used to reduce the original matrix *> to tridiagonal form. *> = 'I': Compute eigenvalues and eigenvectors of the *> tridiagonal matrix. Z is initialized to the identity *> matrix. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is REAL array, dimension (N) *> On entry, the diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is REAL array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', then Z contains the orthogonal *> matrix used in the reduction to tridiagonal form. *> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the *> orthonormal eigenvectors of the original symmetric matrix, *> and if COMPZ = 'I', Z contains the orthonormal eigenvectors *> of the symmetric tridiagonal matrix. *> If COMPZ = '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 *> eigenvectors are desired, then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (max(1,2*N-2)) *> If COMPZ = 'N', then WORK 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: the algorithm has failed to find all the eigenvalues in *> a total of 30*N iterations; if INFO = i, then i *> elements of E have not converged to zero; on exit, D *> and E contain the elements of a symmetric tridiagonal *> matrix which is orthogonally similar to the original *> matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, 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 COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, $ THREE = 3.0E0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH, SLANST, SLAPY2 EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2 * .. * .. External Subroutines .. EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR, $ SLASRT, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = ONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = SLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = SLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = SLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL SLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL SLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = SLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL SLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL SLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.LT.NMAXIT ) $ GO TO 10 DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE GO TO 190 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL SLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF * 190 CONTINUE RETURN * * End of SSTEQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stgevc.f000066400000000000000000001204021522610125300262440ustar00rootroot00000000000000*> \brief \b STGEVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STGEVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> STGEVC computes some or all of the right and/or left eigenvectors of *> a pair of real matrices (S,P), where S is a quasi-triangular matrix *> and P is upper triangular. Matrix pairs of this type are produced by *> the generalized Schur factorization of a matrix pair (A,B): *> *> A = Q*S*Z**T, B = Q*P*Z**T *> *> as computed by SGGHRD + SHGEQZ. *> *> 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: * ========== * *> \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, *> specified 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. 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 matrices S and P. N >= 0. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is REAL array, dimension (LDS,N) *> The upper quasi-triangular matrix S from a generalized Schur *> factorization, as computed by SHGEQZ. *> \endverbatim *> *> \param[in] LDS *> \verbatim *> LDS is INTEGER *> The leading dimension of array S. LDS >= max(1,N). *> \endverbatim *> *> \param[in] P *> \verbatim *> P is REAL array, dimension (LDP,N) *> The upper triangular matrix P from a generalized Schur *> factorization, as computed by SHGEQZ. *> 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks *> of S must be in positive diagonal form. *> \endverbatim *> *> \param[in] LDP *> \verbatim *> LDP is INTEGER *> The leading dimension of array P. LDP >= 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 left Schur vectors returned by SHGEQZ). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of (S,P) 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 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 Z (usually the orthogonal matrix Z *> of right Schur vectors returned by SHGEQZ). *> *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); *> if HOWMNY = 'B' or 'b', the matrix Z*X; *> if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) *> 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 (6*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex *> eigenvalue. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> Allocation of workspace: *> ---------- -- --------- *> *> WORK( j ) = 1-norm of j-th column of A, above the diagonal *> WORK( N+j ) = 1-norm of j-th column of B, above the diagonal *> WORK( 2*N+1:3*N ) = real part of eigenvector *> WORK( 3*N+1:4*N ) = imaginary part of eigenvector *> WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector *> WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector *> *> Rowwise vs. columnwise solution methods: *> ------- -- ---------- -------- ------- *> *> Finding a generalized eigenvector consists basically of solving the *> singular triangular system *> *> (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) *> *> Consider finding the i-th right eigenvector (assume all eigenvalues *> are real). The equation to be solved is: *> n i *> 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 *> k=j k=j *> *> where C = (A - w B) (The components v(i+1:n) are 0.) *> *> The "rowwise" method is: *> *> (1) v(i) := 1 *> for j = i-1,. . .,1: *> i *> (2) compute s = - sum C(j,k) v(k) and *> k=j+1 *> *> (3) v(j) := s / C(j,j) *> *> Step 2 is sometimes called the "dot product" step, since it is an *> inner product between the j-th row and the portion of the eigenvector *> that has been computed so far. *> *> The "columnwise" method consists basically in doing the sums *> for all the rows in parallel. As each v(j) is computed, the *> contribution of v(j) times the j-th column of C is added to the *> partial sums. Since FORTRAN arrays are stored columnwise, this has *> the advantage that at each step, the elements of C that are accessed *> are adjacent to one another, whereas with the rowwise method, the *> elements accessed at a step are spaced LDS (and LDP) words apart. *> *> When finding left eigenvectors, the matrix in question is the *> transpose of the one in storage, so the rowwise method then *> actually accesses columns of A and B at each step, and so is the *> preferred method. *> \endverbatim *> * ===================================================================== SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, 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 HOWMNY, SIDE INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, SAFETY PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ SAFETY = 1.0E+2 ) * .. * .. Local Scalars .. LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK, $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE, $ J, JA, JC, JE, JR, JW, NA, NW REAL ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI, $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A, $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA, $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE, $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX, $ XSCALE * .. * .. Local Arrays .. REAL BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH EXTERNAL LSAME, SLAMCH * .. * .. External Subroutines .. EXTERNAL SGEMV, SLABAD, SLACPY, SLAG2, SLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * IF( LSAME( HOWMNY, 'A' ) ) THEN IHWMNY = 1 ILALL = .TRUE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. ELSE IHWMNY = -1 ILALL = .TRUE. END IF * IF( LSAME( SIDE, 'R' ) ) THEN ISIDE = 1 COMPL = .FALSE. COMPR = .TRUE. ELSE IF( LSAME( SIDE, 'L' ) ) THEN ISIDE = 2 COMPL = .TRUE. COMPR = .FALSE. ELSE IF( LSAME( SIDE, 'B' ) ) THEN ISIDE = 3 COMPL = .TRUE. COMPR = .TRUE. ELSE ISIDE = -1 END IF * INFO = 0 IF( ISIDE.LT.0 ) THEN INFO = -1 ELSE IF( IHWMNY.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGEVC', -INFO ) RETURN END IF * * Count the number of eigenvectors to be computed * IF( .NOT.ILALL ) THEN IM = 0 ILCPLX = .FALSE. DO 10 J = 1, N IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 10 END IF IF( J.LT.N ) THEN IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN IF( SELECT( J ) .OR. SELECT( J+1 ) ) $ IM = IM + 2 ELSE IF( SELECT( J ) ) $ IM = IM + 1 END IF 10 CONTINUE ELSE IM = N END IF * * Check 2-by-2 diagonal blocks of A, B * ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 IF( S( J+1, J ).NE.ZERO ) THEN IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF 20 CONTINUE * IF( ILABAD ) THEN INFO = -5 ELSE IF( ILBBAD ) THEN INFO = -7 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN INFO = -12 ELSE IF( MM.LT.IM ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGEVC', -INFO ) RETURN END IF * * Quick return if possible * M = IM IF( N.EQ.0 ) $ RETURN * * Machine Constants * SAFMIN = SLAMCH( 'Safe minimum' ) BIG = ONE / SAFMIN CALL SLABAD( SAFMIN, BIG ) ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) SMALL = SAFMIN*N / ULP BIG = ONE / SMALL BIGNUM = ONE / ( SAFMIN*N ) * * Compute the 1-norm of each column of the strictly upper triangular * part (i.e., excluding all elements belonging to the diagonal * blocks) of A and B to check for possible overflow in the * triangular solver. * ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) $ ANORM = ANORM + ABS( S( 2, 1 ) ) BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND TEMP = TEMP + ABS( S( I, J ) ) TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) TEMP = TEMP + ABS( S( I, J ) ) TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) 50 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) BSCALE = ONE / MAX( BNORM, SAFMIN ) * * Left eigenvectors * IF( COMPL ) THEN IEIG = 0 * * Main loop over eigenvalues * ILCPLX = .FALSE. DO 220 JE = 1, N * * Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or * (b) this would be the second of a complex pair. * Check for complex eigenvalue, so as to be sure of which * entry(-ies) of SELECT to look at. * IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 220 END IF NW = 1 IF( JE.LT.N ) THEN IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF END IF IF( ILALL ) THEN ILCOMP = .TRUE. ELSE IF( ILCPLX ) THEN ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 ) ELSE ILCOMP = SELECT( JE ) END IF IF( .NOT.ILCOMP ) $ GO TO 220 * * Decide if (a) singular pencil, (b) real eigenvalue, or * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * IEIG = IEIG + 1 DO 60 JR = 1, N VL( JR, IEIG ) = ZERO 60 CONTINUE VL( IEIG, IEIG ) = ONE GO TO 220 END IF END IF * * Clear vector * DO 70 JR = 1, NW*N WORK( 2*N+JR ) = ZERO 70 CONTINUE * T * Compute coefficients in ( a A - b B ) y = 0 * a is ACOEF * b is BCOEFR + i*BCOEFI * IF( .NOT.ILCPLX ) THEN * * Real eigenvalue * TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) SALFAR = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO * * Scale to avoid underflow * SCALE = ONE LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. $ SMALL IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), $ ABS( BCOEFR ) ) ) ) IF( LSA ) THEN ACOEF = ASCALE*( SCALE*SBETA ) ELSE ACOEF = SCALE*ACOEF END IF IF( LSB ) THEN BCOEFR = BSCALE*( SCALE*SALFAR ) ELSE BCOEFR = SCALE*BCOEFR END IF END IF ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) * * First component is 1 * WORK( 2*N+JE ) = ONE XMAX = ONE ELSE * * Complex eigenvalue * CALL SLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI IF( BCOEFI.EQ.ZERO ) THEN INFO = JE RETURN END IF * * Scale to avoid over/underflow * ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) SCALE = ONE IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) $ SCALE = ( SAFMIN / ULP ) / ACOEFA IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) IF( SAFMIN*ACOEFA.GT.ASCALE ) $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) IF( SAFMIN*BCOEFA.GT.BSCALE ) $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) IF( SCALE.NE.ONE ) THEN ACOEF = SCALE*ACOEF ACOEFA = ABS( ACOEF ) BCOEFR = SCALE*BCOEFR BCOEFI = SCALE*BCOEFI BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) END IF * * Compute first two components of eigenvector * TEMP = ACOEF*S( JE+1, JE ) TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO WORK( 2*N+JE+1 ) = -TEMP2R / TEMP WORK( 3*N+JE+1 ) = -TEMP2I / TEMP ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO TEMP = ACOEF*S( JE, JE+1 ) WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* $ S( JE+1, JE+1 ) ) / TEMP WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) END IF * DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * T * Triangular solve of (a A - b B) y = 0 * * T * (rowwise in (a A - b B) , or columnwise in (a A - b B) ) * IL2BY2 = .FALSE. * DO 160 J = JE + NW, N IF( IL2BY2 ) THEN IL2BY2 = .FALSE. GO TO 160 END IF * NA = 1 BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF * * Check whether scaling is necessary for dot products * XSCALE = ONE / MAX( ONE, XMAX ) TEMP = MAX( WORK( J ), WORK( N+J ), $ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) ) IF( IL2BY2 ) $ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ), $ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) ) IF( TEMP.GT.BIGNUM*XSCALE ) THEN DO 90 JW = 0, NW - 1 DO 80 JR = JE, J - 1 WORK( ( JW+2 )*N+JR ) = XSCALE* $ WORK( ( JW+2 )*N+JR ) 80 CONTINUE 90 CONTINUE XMAX = XMAX*XSCALE END IF * * Compute dot products * * j-1 * SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 * a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close * to underflow. (E.g., less than SMALL.) * * DO 120 JW = 1, NW DO 110 JA = 1, NA SUMS( JA, JW ) = ZERO SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 SUMS( JA, JW ) = SUMS( JA, JW ) + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) SUMP( JA, JW ) = SUMP( JA, JW ) + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE 120 CONTINUE * DO 130 JA = 1, NA IF( ILCPLX ) THEN SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + $ BCOEFR*SUMP( JA, 1 ) - $ BCOEFI*SUMP( JA, 2 ) SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + $ BCOEFR*SUMP( JA, 2 ) + $ BCOEFI*SUMP( JA, 1 ) ELSE SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * * T * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN DO 150 JW = 0, NW - 1 DO 140 JR = JE, J - 1 WORK( ( JW+2 )*N+JR ) = SCALE* $ WORK( ( JW+2 )*N+JR ) 140 CONTINUE 150 CONTINUE XMAX = SCALE*XMAX END IF XMAX = MAX( XMAX, TEMP ) 160 CONTINUE * * Copy eigenvector to VL, back transforming if * HOWMNY='B'. * IEIG = IEIG + 1 IF( ILBACK ) THEN DO 170 JW = 0, NW - 1 CALL SGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL, $ WORK( ( JW+2 )*N+JE ), 1, ZERO, $ WORK( ( JW+4 )*N+1 ), 1 ) 170 CONTINUE CALL SLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ), $ LDVL ) IBEG = 1 ELSE CALL SLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ), $ LDVL ) IBEG = JE END IF * * Scale eigenvector * XMAX = ZERO IF( ILCPLX ) THEN DO 180 J = IBEG, N XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+ $ ABS( VL( J, IEIG+1 ) ) ) 180 CONTINUE ELSE DO 190 J = IBEG, N XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) ) 190 CONTINUE END IF * IF( XMAX.GT.SAFMIN ) THEN XSCALE = ONE / XMAX * DO 210 JW = 0, NW - 1 DO 200 JR = IBEG, N VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW ) 200 CONTINUE 210 CONTINUE END IF IEIG = IEIG + NW - 1 * 220 CONTINUE END IF * * Right eigenvectors * IF( COMPR ) THEN IEIG = IM + 1 * * Main loop over eigenvalues * ILCPLX = .FALSE. DO 500 JE = N, 1, -1 * * Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or * (b) this would be the second of a complex pair. * Check for complex eigenvalue, so as to be sure of which * entry(-ies) of SELECT to look at -- if complex, SELECT(JE) * or SELECT(JE-1). * If this is a complex pair, the 2-by-2 diagonal block * corresponding to the eigenvalue is in rows/columns JE-1:JE * IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 500 END IF NW = 1 IF( JE.GT.1 ) THEN IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF END IF IF( ILALL ) THEN ILCOMP = .TRUE. ELSE IF( ILCPLX ) THEN ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 ) ELSE ILCOMP = SELECT( JE ) END IF IF( .NOT.ILCOMP ) $ GO TO 500 * * Decide if (a) singular pencil, (b) real eigenvalue, or * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * IEIG = IEIG - 1 DO 230 JR = 1, N VR( JR, IEIG ) = ZERO 230 CONTINUE VR( IEIG, IEIG ) = ONE GO TO 500 END IF END IF * * Clear vector * DO 250 JW = 0, NW - 1 DO 240 JR = 1, N WORK( ( JW+2 )*N+JR ) = ZERO 240 CONTINUE 250 CONTINUE * * Compute coefficients in ( a A - b B ) x = 0 * a is ACOEF * b is BCOEFR + i*BCOEFI * IF( .NOT.ILCPLX ) THEN * * Real eigenvalue * TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) SALFAR = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO * * Scale to avoid underflow * SCALE = ONE LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. $ SMALL IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), $ ABS( BCOEFR ) ) ) ) IF( LSA ) THEN ACOEF = ASCALE*( SCALE*SBETA ) ELSE ACOEF = SCALE*ACOEF END IF IF( LSB ) THEN BCOEFR = BSCALE*( SCALE*SALFAR ) ELSE BCOEFR = SCALE*BCOEFR END IF END IF ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) * * First component is 1 * WORK( 2*N+JE ) = ONE XMAX = ONE * * Compute contribution from column JE of A and B to sum * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * CALL SLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN INFO = JE - 1 RETURN END IF * * Scale to avoid over/underflow * ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) SCALE = ONE IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) $ SCALE = ( SAFMIN / ULP ) / ACOEFA IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) IF( SAFMIN*ACOEFA.GT.ASCALE ) $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) IF( SAFMIN*BCOEFA.GT.BSCALE ) $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) IF( SCALE.NE.ONE ) THEN ACOEF = SCALE*ACOEF ACOEFA = ABS( ACOEF ) BCOEFR = SCALE*BCOEFR BCOEFI = SCALE*BCOEFI BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) END IF * * Compute first two components of eigenvector * and contribution to sums * TEMP = ACOEF*S( JE, JE-1 ) TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO WORK( 2*N+JE-1 ) = -TEMP2R / TEMP WORK( 3*N+JE-1 ) = -TEMP2I / TEMP ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO TEMP = ACOEF*S( JE-1, JE ) WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* $ S( JE-1, JE-1 ) ) / TEMP WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) ) * * Compute contribution from columns JE and JE-1 * of A and B to the sums. * CREALA = ACOEF*WORK( 2*N+JE-1 ) CIMAGA = ACOEF*WORK( 3*N+JE-1 ) CREALB = BCOEFR*WORK( 2*N+JE-1 ) - $ BCOEFI*WORK( 3*N+JE-1 ) CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) + $ BCOEFR*WORK( 3*N+JE-1 ) CRE2A = ACOEF*WORK( 2*N+JE ) CIM2A = ACOEF*WORK( 3*N+JE ) CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + $ CREALB*P( JR, JE-1 ) - $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + $ CIMAGB*P( JR, JE-1 ) - $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * Columnwise triangular solve of (a A - b B) x = 0 * IL2BY2 = .FALSE. DO 370 J = JE - NW, 1, -1 * * If a 2-by-2 block, is in position j-1:j, wait until * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN * DO 290 JW = 0, NW - 1 DO 280 JR = 1, JE WORK( ( JW+2 )*N+JR ) = SCALE* $ WORK( ( JW+2 )*N+JR ) 280 CONTINUE 290 CONTINUE END IF XMAX = MAX( SCALE*XMAX, TEMP ) * DO 310 JW = 1, NW DO 300 JA = 1, NA WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW ) 300 CONTINUE 310 CONTINUE * * w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * * Check whether scaling is necessary for sum. * XSCALE = ONE / MAX( ONE, XMAX ) TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J ) IF( IL2BY2 ) $ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA* $ WORK( N+J+1 ) ) TEMP = MAX( TEMP, ACOEFA, BCOEFA ) IF( TEMP.GT.BIGNUM*XSCALE ) THEN * DO 330 JW = 0, NW - 1 DO 320 JR = 1, JE WORK( ( JW+2 )*N+JR ) = XSCALE* $ WORK( ( JW+2 )*N+JR ) 320 CONTINUE 330 CONTINUE XMAX = XMAX*XSCALE END IF * * Compute the contributions of the off-diagonals of * column j (and j+1, if 2-by-2 block) of A and B to the * sums. * * DO 360 JA = 1, NA IF( ILCPLX ) THEN CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CIMAGA = ACOEF*WORK( 3*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) - $ BCOEFI*WORK( 3*N+J+JA-1 ) CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) + $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - $ CREALA*S( JR, J+JA-1 ) + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - $ CIMAGA*S( JR, J+JA-1 ) + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - $ CREALA*S( JR, J+JA-1 ) + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE END IF * IL2BY2 = .FALSE. 370 CONTINUE * * Copy eigenvector to VR, back transforming if * HOWMNY='B'. * IEIG = IEIG - NW IF( ILBACK ) THEN * DO 410 JW = 0, NW - 1 DO 380 JR = 1, N WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )* $ VR( JR, 1 ) 380 CONTINUE * * A series of compiler directives to defeat * vectorization for the next loop * * DO 400 JC = 2, JE DO 390 JR = 1, N WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) + $ WORK( ( JW+2 )*N+JC )*VR( JR, JC ) 390 CONTINUE 400 CONTINUE 410 CONTINUE * DO 430 JW = 0, NW - 1 DO 420 JR = 1, N VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR ) 420 CONTINUE 430 CONTINUE * IEND = N ELSE DO 450 JW = 0, NW - 1 DO 440 JR = 1, N VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR ) 440 CONTINUE 450 CONTINUE * IEND = JE END IF * * Scale eigenvector * XMAX = ZERO IF( ILCPLX ) THEN DO 460 J = 1, IEND XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+ $ ABS( VR( J, IEIG+1 ) ) ) 460 CONTINUE ELSE DO 470 J = 1, IEND XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) ) 470 CONTINUE END IF * IF( XMAX.GT.SAFMIN ) THEN XSCALE = ONE / XMAX DO 490 JW = 0, NW - 1 DO 480 JR = 1, IEND VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW ) 480 CONTINUE 490 CONTINUE END IF 500 CONTINUE END IF * RETURN * * End of STGEVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stgex2.f000066400000000000000000000570201522610125300261720ustar00rootroot00000000000000*> \brief \b STGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STGEX2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) *> of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair *> (A, B) by an orthogonal equivalence transformation. *> *> (A, B) must be in generalized real Schur canonical form (as returned *> by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 *> diagonal blocks. B is upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T *> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 arrays, dimensions (LDA,N) *> On entry, the matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \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 arrays, dimensions (LDB,N) *> On entry, the matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDZ,N) *> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. *> On exit, the updated matrix Q. *> Not referenced if WANTQ = .FALSE.. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,N) *> On entry, if WANTZ =.TRUE., the orthogonal matrix Z. *> On exit, the updated matrix Z. *> Not referenced if WANTZ = .FALSE.. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index to the first block (A11, B11). 1 <= J1 <= N. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The order of the first block (A11, B11). N1 = 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> The order of the second block (A22, B22). N2 = 0, 1 or 2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (MAX(1,LWORK)). *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit *> >0: If INFO = 1, the transformed matrix (A, B) would be *> too far from generalized Schur form; the blocks are *> not swapped and (A, B) and (Q, Z) are unchanged. *> The problem of swapping is too ill-conditioned. *> <0: If INFO = -16: LWORK is too small. Appropriate value *> for LWORK is returned in WORK(1). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEauxiliary * *> \par Further Details: * ===================== *> *> In the current code both weak and strong stability tests are *> performed. The user can omit the strong stability test by changing *> the internal logical parameter WANDS to .FALSE.. See ref. [2] for *> details. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> \endverbatim *> * ===================================================================== SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 WANTQ, WANTZ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * Replaced various illegal calls to SCOPY by calls to SLASET, or by DO * loops. Sven Hammarling, 1/5/02. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL TWENTY PARAMETER ( TWENTY = 2.0E+01 ) INTEGER LDST PARAMETER ( LDST = 4 ) LOGICAL WANDS PARAMETER ( WANDS = .TRUE. ) * .. * .. Local Scalars .. LOGICAL STRONG, WEAK INTEGER I, IDUM, LINFO, M REAL BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS * .. * .. Local Arrays .. INTEGER IWORK( LDST ) REAL AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ), $ IRCOP( LDST, LDST ), LI( LDST, LDST ), $ LICOP( LDST, LDST ), S( LDST, LDST ), $ SCPY( LDST, LDST ), T( LDST, LDST ), $ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST ) * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL SGEMM, SGEQR2, SGERQ2, SLACPY, SLAGV2, SLARTG, $ SLASET, SLASSQ, SORG2R, SORGR2, SORM2R, SORMR2, $ SROT, SSCAL, STGSY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 ) $ RETURN IF( N1.GT.N .OR. ( J1+N1 ).GT.N ) $ RETURN M = N1 + N2 IF( LWORK.LT.MAX( N*M, M*M*2 ) ) THEN INFO = -16 WORK( 1 ) = MAX( N*M, M*M*2 ) RETURN END IF * WEAK = .FALSE. STRONG = .FALSE. * * Make a local copy of selected block * CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST ) CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST ) CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) * * Compute threshold for testing acceptance of swapping. * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS DSCALE = ZERO DSUM = ONE CALL SLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM ) CALL SLACPY( 'Full', M, M, T, LDST, WORK, M ) CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM ) DNORM = DSCALE*SQRT( DSUM ) * * THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * on 04/01/10. * "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by * Jim Demmel and Guillaume Revy. See forum post 1783. * THRESH = MAX( TWENTY*EPS*DNORM, SMLNUM ) * IF( M.EQ.2 ) THEN * * CASE 1: Swap 1-by-1 and 1-by-1 blocks. * * Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks * using Givens rotations and perform the swap tentatively. * F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) SB = ABS( T( 2, 2 ) ) SA = ABS( S( 2, 2 ) ) CALL SLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM ) IR( 2, 1 ) = -IR( 1, 2 ) IR( 2, 2 ) = IR( 1, 1 ) CALL SROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL SROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) IF( SA.GE.SB ) THEN CALL SLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), $ DDUM ) ELSE CALL SLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), $ DDUM ) END IF CALL SROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ), $ LI( 2, 1 ) ) CALL SROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ), $ LI( 2, 1 ) ) LI( 2, 2 ) = LI( 1, 1 ) LI( 1, 2 ) = -LI( 2, 1 ) * * Weak stability test: * |S21| + |T21| <= O(EPS * F-norm((S, T))) * WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) WEAK = WS.LE.THRESH IF( .NOT.WEAK ) $ GO TO 70 * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL**T*S*QR, B-QL**T*T*QR)) <= O(EPS*F-norm((A, B))) * CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), $ M ) CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) DSCALE = ZERO DSUM = ONE CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) * CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), $ M ) CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) STRONG = SS.LE.THRESH IF( .NOT.STRONG ) $ GO TO 70 END IF * * Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and * (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). * CALL SROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL SROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL SROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, $ LI( 1, 1 ), LI( 2, 1 ) ) CALL SROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, $ LI( 1, 1 ), LI( 2, 1 ) ) * * Set N1-by-N2 (2,1) - blocks to ZERO. * A( J1+1, J1 ) = ZERO B( J1+1, J1 ) = ZERO * * Accumulate transformations into Q and Z if requested. * IF( WANTZ ) $ CALL SROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) IF( WANTQ ) $ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ), $ LI( 2, 1 ) ) * * Exit with INFO = 0 if swap was successfully performed. * RETURN * ELSE * * CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 * and 2-by-2 blocks. * * Solve the generalized Sylvester equation * S11 * R - L * S22 = SCALE * S12 * T11 * R - L * T22 = SCALE * T12 * for R and L. Solutions in LI and IR. * CALL SLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST ) CALL SLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST, $ IR( N2+1, N1+1 ), LDST ) CALL STGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST, $ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ), $ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM, $ LINFO ) * * Compute orthogonal matrix QL: * * QL**T * LI = [ TL ] * [ 0 ] * where * LI = [ -L ] * [ SCALE * identity(N2) ] * DO 10 I = 1, N2 CALL SSCAL( N1, -ONE, LI( 1, I ), 1 ) LI( N1+I, I ) = SCALE 10 CONTINUE CALL SGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL SORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute orthogonal matrix RQ: * * IR * RQ**T = [ 0 TR], * * where IR = [ SCALE * identity(N1), R ] * DO 20 I = 1, N1 IR( N2+I, I ) = SCALE 20 CONTINUE CALL SGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL SORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Perform the swapping tentatively: * CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S, $ LDST ) CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T, $ LDST ) CALL SLACPY( 'F', M, M, S, LDST, SCPY, LDST ) CALL SLACPY( 'F', M, M, T, LDST, TCPY, LDST ) CALL SLACPY( 'F', M, M, IR, LDST, IRCOP, LDST ) CALL SLACPY( 'F', M, M, LI, LDST, LICOP, LDST ) * * Triangularize the B-part by an RQ factorization. * Apply transformation (from left) to A-part, giving S. * CALL SGERQ2( M, M, T, LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL SORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK, $ LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL SORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK, $ LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute F-norm(S21) in BRQA21. (T21 is 0.) * DSCALE = ZERO DSUM = ONE DO 30 I = 1, N2 CALL SLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM ) 30 CONTINUE BRQA21 = DSCALE*SQRT( DSUM ) * * Triangularize the B-part by a QR factorization. * Apply transformation (from right) to A-part, giving S. * CALL SGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL SORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST, $ WORK, INFO ) CALL SORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST, $ WORK, INFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute F-norm(S21) in BQRA21. (T21 is 0.) * DSCALE = ZERO DSUM = ONE DO 40 I = 1, N2 CALL SLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM ) 40 CONTINUE BQRA21 = DSCALE*SQRT( DSUM ) * * Decide which method to use. * Weak stability test: * F-norm(S21) <= O(EPS * F-norm((S, T))) * IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN CALL SLACPY( 'F', M, M, SCPY, LDST, S, LDST ) CALL SLACPY( 'F', M, M, TCPY, LDST, T, LDST ) CALL SLACPY( 'F', M, M, IRCOP, LDST, IR, LDST ) CALL SLACPY( 'F', M, M, LICOP, LDST, LI, LDST ) ELSE IF( BRQA21.GE.THRESH ) THEN GO TO 70 END IF * * Set lower triangle of B-part to zero * CALL SLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL*S*QR**T, B-QL*T*QR**T)) <= O(EPS*F-norm((A,B))) * CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), $ M ) CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) DSCALE = ZERO DSUM = ONE CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) * CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), $ M ) CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) STRONG = ( SS.LE.THRESH ) IF( .NOT.STRONG ) $ GO TO 70 * END IF * * If the swap is accepted ("weakly" and "strongly"), apply the * transformations and set N1-by-N2 (2,1)-block to zero. * CALL SLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) * * copy back M-by-M diagonal block starting at index J1 of (A, B) * CALL SLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA ) CALL SLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB ) CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST ) * * Standardize existing 2-by-2 blocks. * CALL SLASET( 'Full', M, M, ZERO, ZERO, WORK, M ) WORK( 1 ) = ONE T( 1, 1 ) = ONE IDUM = LWORK - M*M - 2 IF( N2.GT.1 ) THEN CALL SLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE, $ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) ) WORK( M+1 ) = -WORK( 2 ) WORK( M+2 ) = WORK( 1 ) T( N2, N2 ) = T( 1, 1 ) T( 1, 2 ) = -T( 2, 1 ) END IF WORK( M*M ) = ONE T( M, M ) = ONE * IF( N1.GT.1 ) THEN CALL SLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB, $ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ), $ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ), $ T( M, M-1 ) ) WORK( M*M ) = WORK( N2*M+N2+1 ) WORK( M*M-1 ) = -WORK( N2*M+N2+2 ) T( M, M ) = T( N2+1, N2+1 ) T( M-1, M ) = -T( M, M-1 ) END IF CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ), $ LDA, ZERO, WORK( M*M+1 ), N2 ) CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ), $ LDA ) CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ), $ LDB, ZERO, WORK( M*M+1 ), N2 ) CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ), $ LDB ) CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO, $ WORK( M*M+1 ), M ) CALL SLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST ) CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA, $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) CALL SLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA ) CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB, $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) CALL SLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB ) CALL SGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO, $ WORK, M ) CALL SLACPY( 'Full', M, M, WORK, M, IR, LDST ) * * Accumulate transformations into Q and Z if requested. * IF( WANTQ ) THEN CALL SGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI, $ LDST, ZERO, WORK, N ) CALL SLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ ) * END IF * IF( WANTZ ) THEN CALL SGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR, $ LDST, ZERO, WORK, N ) CALL SLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ ) * END IF * * Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and * (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). * I = J1 + M IF( I.LE.N ) THEN CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, $ A( J1, I ), LDA, ZERO, WORK, M ) CALL SLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA ) CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, $ B( J1, I ), LDB, ZERO, WORK, M ) CALL SLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB ) END IF I = J1 - 1 IF( I.GT.0 ) THEN CALL SGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR, $ LDST, ZERO, WORK, I ) CALL SLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA ) CALL SGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR, $ LDST, ZERO, WORK, I ) CALL SLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB ) END IF * * Exit with INFO = 0 if swap was successfully performed. * RETURN * END IF * * Exit with INFO = 1 if swap was rejected. * 70 CONTINUE * INFO = 1 RETURN * * End of STGEX2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stgexc.f000066400000000000000000000373571522610125300262660ustar00rootroot00000000000000*> \brief \b STGEXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STGEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STGEXC reorders the generalized real Schur decomposition of a real *> matrix pair (A,B) using an orthogonal equivalence transformation *> *> (A, B) = Q * (A, B) * Z**T, *> *> so that the diagonal block of (A, B) with row index IFST is moved *> to row ILST. *> *> (A, B) must be in generalized real Schur canonical form (as returned *> by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 *> diagonal blocks. B is upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T *> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 matrix A in generalized real Schur canonical *> form. *> On exit, the updated matrix A, again in generalized *> real Schur canonical form. *> \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 matrix B in generalized real Schur canonical *> form (A,B). *> On exit, the updated matrix B, again in generalized *> real Schur canonical form (A,B). *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDZ,N) *> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. *> On exit, the updated matrix Q. *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., the orthogonal matrix Z. *> On exit, the updated matrix Z. *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in,out] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> Specify the reordering of the diagonal blocks of (A, B). *> The block with row index IFST is moved to row ILST, by a *> sequence of swapping between adjacent blocks. *> On exit, if IFST pointed on entry to the second row of *> a 2-by-2 block, it is changed to point to the first row; *> ILST always points to the first row of the block in its *> final position (which may differ from its input value by *> +1 or -1). 1 <= IFST, ILST <= 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 dimension of the array WORK. *> LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. *> *> 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. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. (A, B) may have been partially reordered, *> and ILST points to the first row of the current *> position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realGEcomputational * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \endverbatim *> * ===================================================================== SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, 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 .. LOGICAL WANTQ, WANTZ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER HERE, LWMIN, NBF, NBL, NBNEXT * .. * .. External Subroutines .. EXTERNAL STGEX2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input arguments. * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -12 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LWMIN = 1 ELSE LWMIN = 4*N + 16 END IF WORK(1) = LWMIN * IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN INFO = -15 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGEXC', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of the specified block and find out * if it is 1-by-1 or 2-by-2. * IF( IFST.GT.1 ) THEN IF( A( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( A( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out if it is 1-by-1 or 2-by-2. * IF( ILST.GT.1 ) THEN IF( A( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( A( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST. * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap with next one below. * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1-by-1 or 2-by-2. * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2-by-2 block breaks into two 1-by-1 blocks. * IF( NBF.EQ.2 ) THEN IF( A( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1-by-1 blocks, each of which * must be swapped individually. * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( A( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 * ELSE * * Recompute NBNEXT in case of 2-by-2 split. * IF( A( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2-by-2 block did not split. * CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2-by-2 block did split. * CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 END IF * END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 ELSE HERE = IFST * 20 CONTINUE * * Swap with next one below. * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1-by-1 or 2-by-2. * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( A( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2-by-2 block breaks into two 1-by-1 blocks. * IF( NBF.EQ.2 ) THEN IF( A( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1-by-1 blocks, each of which * must be swapped individually. * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( A( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 ELSE * * Recompute NBNEXT in case of 2-by-2 split. * IF( A( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2-by-2 block did not split. * CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2-by-2 block did split. * CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE WORK( 1 ) = LWMIN RETURN * * End of STGEXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stgsen.f000066400000000000000000000713651522610125300262710ustar00rootroot00000000000000*> \brief \b STGSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STGSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ M, N * REAL PL, PR * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STGSEN reorders the generalized real Schur decomposition of a real *> matrix pair (A, B) (in terms of an orthonormal equivalence trans- *> formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues *> appears in the leading diagonal blocks of the upper quasi-triangular *> matrix A and the upper triangular B. The leading columns of Q and *> Z form orthonormal bases of the corresponding left and right eigen- *> spaces (deflating subspaces). (A, B) must be in generalized real *> Schur canonical form (as returned by SGGES), i.e. A is block upper *> triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper *> triangular. *> *> STGSEN also computes the generalized eigenvalues *> *> w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) *> *> of the reordered matrix pair (A, B). *> *> Optionally, STGSEN computes the estimates of reciprocal condition *> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), *> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) *> between the matrix pairs (A11, B11) and (A22,B22) that correspond to *> the selected cluster and the eigenvalues outside the cluster, resp., *> and norms of "projections" onto left and right eigenspaces w.r.t. *> the selected cluster in the (1,1)-block. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (PL and PR) or the deflating subspaces *> (Difu and Difl): *> =0: Only reorder w.r.t. SELECT. No extras. *> =1: Reciprocal of norms of "projections" onto left and right *> eigenspaces w.r.t. the selected cluster (PL and PR). *> =2: Upper bounds on Difu and Difl. F-norm-based estimate *> (DIF(1:2)). *> =3: Estimate of Difu and Difl. 1-norm-based estimate *> (DIF(1:2)). *> About 5 times as expensive as IJOB = 2. *> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic *> version to get it all. *> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) *> \endverbatim *> *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. *> To select a real eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. To select a complex conjugate pair of eigenvalues *> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, *> either SELECT(j) or SELECT(j+1) or both must be set to *> .TRUE.; a complex conjugate pair of eigenvalues must be *> either both included in the cluster or both excluded. *> \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 upper quasi-triangular matrix A, with (A, B) in *> generalized real Schur canonical form. *> On exit, A is overwritten by the reordered matrix A. *> \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 upper triangular matrix B, with (A, B) in *> generalized real Schur canonical form. *> On exit, B is overwritten by the reordered matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is REAL array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is REAL array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is REAL array, dimension (N) *> *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real generalized Schur form of (A,B) were further reduced *> to triangular form using complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. *> On exit, Q has been postmultiplied by the left orthogonal *> transformation matrix which reorder (A, B); The leading M *> columns of Q form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> and if WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is REAL array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. *> On exit, Z has been postmultiplied by the left orthogonal *> transformation matrix which reorder (A, B); The leading M *> columns of Z form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified pair of left and right eigen- *> spaces (deflating subspaces). 0 <= M <= N. *> \endverbatim *> *> \param[out] PL *> \verbatim *> PL is REAL *> \endverbatim *> *> \param[out] PR *> \verbatim *> PR is REAL *> *> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the *> reciprocal of the norm of "projections" onto left and right *> eigenspaces with respect to the selected cluster. *> 0 < PL, PR <= 1. *> If M = 0 or M = N, PL = PR = 1. *> If IJOB = 0, 2 or 3, PL and PR are not referenced. *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is REAL array, dimension (2). *> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. *> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on *> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based *> estimates of Difu and Difl. *> If M = 0 or N, DIF(1:2) = F-norm([A, B]). *> If IJOB = 0 or 1, DIF is not referenced. *> \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. LWORK >= 4*N+16. *> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). *> If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-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] 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. LIWORK >= 1. *> If IJOB = 1, 2 or 4, LIWORK >= N+6. *> If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). *> *> 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. *> =1: Reordering of (A, B) failed because the transformed *> matrix pair (A, B) would be too far from generalized *> Schur form; the problem is very ill-conditioned. *> (A, B) may have been partially reordered. *> If requested, 0 is returned in DIF(*), PL and PR. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup realOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> STGSEN first collects the selected eigenvalues by computing *> orthogonal U and W that move them to the top left corner of (A, B). *> In other words, the selected eigenvalues are the eigenvalues of *> (A11, B11) in: *> *> U**T*(A, B)*W = (A11 A12) (B11 B12) n1 *> ( 0 A22),( 0 B22) n2 *> n1 n2 n1 n2 *> *> where N = n1+n2 and U**T means the transpose of U. The first n1 columns *> of U and W span the specified pair of left and right eigenspaces *> (deflating subspaces) of (A, B). *> *> If (A, B) has been obtained from the generalized real Schur *> decomposition of a matrix pair (C, D) = Q*(A, B)*Z**T, then the *> reordered generalized real Schur form of (C, D) is given by *> *> (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T, *> *> and the first n1 columns of Q*U and Z*W span the corresponding *> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). *> *> Note that if the selected eigenvalue is sufficiently ill-conditioned, *> then its value may differ significantly from its value before *> reordering. *> *> The reciprocal condition numbers of the left and right eigenspaces *> spanned by the first n1 columns of U and W (or Q*U and Z*W) may *> be returned in DIF(1:2), corresponding to Difu and Difl, resp. *> *> The Difu and Difl are defined as: *> *> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) *> and *> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], *> *> where sigma-min(Zu) is the smallest singular value of the *> (2*n1*n2)-by-(2*n1*n2) matrix *> *> Zu = [ kron(In2, A11) -kron(A22**T, In1) ] *> [ kron(In2, B11) -kron(B22**T, In1) ]. *> *> Here, Inx is the identity matrix of size nx and A22**T is the *> transpose of A22. kron(X, Y) is the Kronecker product between *> the matrices X and Y. *> *> When DIF(2) is small, small changes in (A, B) can cause large changes *> in the deflating subspace. An approximate (asymptotic) bound on the *> maximum angular error in the computed deflating subspaces is *> *> EPS * norm((A, B)) / DIF(2), *> *> where EPS is the machine precision. *> *> The reciprocal norm of the projectors on the left and right *> eigenspaces associated with (A11, B11) may be returned in PL and PR. *> They are computed as follows. First we compute L and R so that *> P*(A, B)*Q is block diagonal, where *> *> P = ( I -L ) n1 Q = ( I R ) n1 *> ( 0 I ) n2 and ( 0 I ) n2 *> n1 n2 n1 n2 *> *> and (L, R) is the solution to the generalized Sylvester equation *> *> A11*R - L*A22 = -A12 *> B11*R - L*B22 = -B12 *> *> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). *> An approximate (asymptotic) bound on the average absolute error of *> the selected eigenvalues is *> *> EPS * norm((A, B)) / PL. *> *> There are also global error bounds which valid for perturbations up *> to a certain restriction: A lower bound (x) on the smallest *> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and *> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), *> (i.e. (A + E, B + F), is *> *> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). *> *> An approximate bound on x can be computed from DIF(1:2), PL and PR. *> *> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed *> (L', R') and unperturbed (L, R) left and right deflating subspaces *> associated with the selected cluster in the (1,1)-blocks can be *> bounded as *> *> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) *> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) *> *> See LAPACK User's Guide section 4.11 or the following references *> for more information. *> *> Note that if the default method for computing the Frobenius-norm- *> based estimate DIF is not wanted (see SLATDF), then the parameter *> IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF *> (IJOB = 2 will be used)). See STGSYL for more details. *> \endverbatim * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> \endverbatim *> * ===================================================================== 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.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 .. LOGICAL WANTQ, WANTZ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, $ M, N REAL PL, PR * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IDIFJB PARAMETER ( IDIFJB = 3 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2, $ WANTP INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN, $ MN2, N1, N2 REAL DSCALE, DSUM, EPS, RDSCAL, SMLNUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL, $ XERBLA * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -14 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -16 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGSEN', -INFO ) RETURN END IF * * Get machine constants * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS IERR = 0 * WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 WANTD = WANTD1 .OR. WANTD2 * * Set M to the dimension of the specified pair of deflating * subspaces. * M = 0 PAIR = .FALSE. IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( A( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 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) ) LIWMIN = MAX( 1, N+6 ) ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN LWMIN = MAX( 1, 4*N+16, 4*M*(N-M) ) LIWMIN = MAX( 1, 2*M*(N-M), N+6 ) ELSE LWMIN = MAX( 1, 4*N+16 ) LIWMIN = 1 END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -22 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -24 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTP ) THEN PL = ONE PR = ONE END IF IF( WANTD ) THEN DSCALE = ZERO DSUM = ONE DO 20 I = 1, N CALL SLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) CALL SLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 20 CONTINUE DIF( 1 ) = DSCALE*SQRT( DSUM ) DIF( 2 ) = DIF( 1 ) END IF GO TO 60 END IF * * Collect the selected blocks at the top-left corner of (A, B). * KS = 0 PAIR = .FALSE. DO 30 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE * SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF * IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * Perform the reordering of diagonal blocks in (A, B) * by orthogonal transformation matrices and update * Q and Z accordingly (if requested): * KK = K IF( K.NE.KS ) $ CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, KK, KS, WORK, LWORK, IERR ) * IF( IERR.GT.0 ) THEN * * Swap is rejected: exit. * INFO = 1 IF( WANTP ) THEN PL = ZERO PR = ZERO END IF IF( WANTD ) THEN DIF( 1 ) = ZERO DIF( 2 ) = ZERO END IF GO TO 60 END IF * IF( PAIR ) $ KS = KS + 1 END IF END IF 30 CONTINUE IF( WANTP ) THEN * * Solve generalized Sylvester equation for R and L * and compute PL and PR. * N1 = M N2 = N - M I = N1 + 1 IJB = 0 CALL SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), $ N1 ) CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Estimate the reciprocal of norms of "projections" onto left * and right eigenspaces. * RDSCAL = ZERO DSUM = ONE CALL SLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) PL = RDSCAL*SQRT( DSUM ) IF( PL.EQ.ZERO ) THEN PL = ONE ELSE PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) END IF RDSCAL = ZERO DSUM = ONE CALL SLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) PR = RDSCAL*SQRT( DSUM ) IF( PR.EQ.ZERO ) THEN PR = ONE ELSE PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) END IF END IF * IF( WANTD ) THEN * * Compute estimates of Difu and Difl. * IF( WANTD1 ) THEN N1 = M N2 = N - M I = N1 + 1 IJB = IDIFJB * * Frobenius norm-based Difu-estimate. * CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), $ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Frobenius norm-based Difl-estimate. * CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), $ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) ELSE * * * Compute 1-norm-based estimates of Difu and Difl using * reversed communication with SLACN2. In each step a * generalized Sylvester equation or a transposed variant * is solved. * KASE = 0 N1 = M N2 = N - M I = N1 + 1 IJB = 0 MN2 = 2*N1*N2 * * 1-norm-based estimate of Difu. * 40 CONTINUE CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation. * CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 40 END IF DIF( 1 ) = DSCALE / DIF( 1 ) * * 1-norm-based estimate of Difl. * 50 CONTINUE CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation. * CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 50 END IF DIF( 2 ) = DSCALE / DIF( 2 ) * END IF END IF * 60 CONTINUE * * Compute generalized eigenvalues of reordered pair (A, B) and * normalize the generalized Schur form. * PAIR = .FALSE. DO 70 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE * IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. END IF END IF * IF( PAIR ) THEN * * Compute the eigenvalue(s) at position K. * WORK( 1 ) = A( K, K ) WORK( 2 ) = A( K+1, K ) WORK( 3 ) = A( K, K+1 ) WORK( 4 ) = A( K+1, K+1 ) WORK( 5 ) = B( K, K ) WORK( 6 ) = B( K+1, K ) WORK( 7 ) = B( K, K+1 ) WORK( 8 ) = B( K+1, K+1 ) CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ), $ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ), $ ALPHAI( K ) ) ALPHAI( K+1 ) = -ALPHAI( K ) * ELSE * IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN * * If B(K,K) is negative, make it positive * DO 80 I = 1, N A( K, I ) = -A( K, I ) B( K, I ) = -B( K, I ) IF( WANTQ ) Q( I, K ) = -Q( I, K ) 80 CONTINUE END IF * ALPHAR( K ) = A( K, K ) ALPHAI( K ) = ZERO BETA( K ) = B( K, K ) * END IF END IF 70 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of STGSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stgsy2.f000066400000000000000000001076601522610125300262170ustar00rootroot00000000000000*> \brief \b STGSY2 solves the generalized Sylvester equation (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STGSY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ PQ * REAL RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STGSY2 solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F, *> *> using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, *> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, *> N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) *> must be in generalized Schur canonical form, i.e. A, B are upper *> quasi triangular and D, E are upper triangular. The solution (R, L) *> overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor *> chosen to avoid overflow. *> *> In matrix notation solving equation (1) corresponds to solve *> Z*x = scale*b, where Z is defined as *> *> Z = [ kron(In, A) -kron(B**T, Im) ] (2) *> [ kron(In, D) -kron(E**T, Im) ], *> *> Ik is the identity matrix of size k and X**T is the transpose of X. *> kron(X, Y) is the Kronecker product between the matrices X and Y. *> In the process of solving (1), we solve a number of such systems *> where Dim(In), Dim(In) = 1 or 2. *> *> If TRANS = 'T', solve the transposed system Z**T*y = scale*b for y, *> which is equivalent to solve for R and L in *> *> A**T * R + D**T * L = scale * C (3) *> R * B**T + L * E**T = scale * -F *> *> This case is used to compute an estimate of Dif[(A, D), (B, E)] = *> sigma_min(Z) using reverse communicaton with SLACON. *> *> STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL *> of an upper bound on the separation between to matrix pairs. Then *> the input (A, D), (B, E) are sub-pencils of the matrix pair in *> STGSYL. See STGSYL for details. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T': solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> = 0: solve (1) only. *> = 1: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (look ahead strategy is used). *> = 2: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (SGECON on sub-systems is used.) *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the order of A and D, and the row *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of B and E, and the column *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA, M) *> On entry, A contains an upper quasi triangular matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the matrix A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB, N) *> On entry, B contains an upper quasi triangular matrix. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is REAL array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1). *> On exit, if IJOB = 0, C has been overwritten by the *> solution R. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the matrix C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is REAL array, dimension (LDD, M) *> On entry, D contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the matrix D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is REAL array, dimension (LDE, N) *> On entry, E contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the matrix E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is REAL array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1). *> On exit, if IJOB = 0, F has been overwritten by the *> solution L. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the matrix F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions *> R and L (C and F on entry) will hold the solutions to a *> slightly perturbed system but the input matrices A, B, D and *> E have not been changed. If SCALE = 0, R and L will hold the *> solutions to the homogeneous system with C = F = 0. Normally, *> SCALE = 1. *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is REAL *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by STGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is REAL *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when STGSY2 is called by *> STGSYL. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+N+2) *> \endverbatim *> *> \param[out] PQ *> \verbatim *> PQ is INTEGER *> On exit, the number of subsystems (of size 2-by-2, 4-by-4 and *> 8-by-8) solved by this routine. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, if INFO is set to *> =0: Successful exit *> <0: If INFO = -i, the i-th argument had an illegal value. *> >0: The matrix pairs (A, D) and (B, E) have common or very *> close eigenvalues. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realSYauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, $ PQ REAL RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * ===================================================================== * Replaced various illegal calls to SCOPY by calls to SLASET. * Sven Hammarling, 27/5/02. * * .. Parameters .. INTEGER LDZ PARAMETER ( LDZ = 8 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, $ K, MB, NB, P, Q, ZDIM REAL ALPHA, SCALOC * .. * .. Local Arrays .. INTEGER IPIV( LDZ ), JPIV( LDZ ) REAL RHS( LDZ ), Z( LDZ, LDZ ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SGEMM, SGEMV, SGER, SGESC2, $ SGETC2, SSCAL, SLASET, SLATDF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 IERR = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGSY2', -INFO ) RETURN END IF * * Determine block structure of A * PQ = 0 P = 0 I = 1 10 CONTINUE IF( I.GT.M ) $ GO TO 20 P = P + 1 IWORK( P ) = I IF( I.EQ.M ) $ GO TO 20 IF( A( I+1, I ).NE.ZERO ) THEN I = I + 2 ELSE I = I + 1 END IF GO TO 10 20 CONTINUE IWORK( P+1 ) = M + 1 * * Determine block structure of B * Q = P + 1 J = 1 30 CONTINUE IF( J.GT.N ) $ GO TO 40 Q = Q + 1 IWORK( Q ) = J IF( J.EQ.N ) $ GO TO 40 IF( B( J+1, J ).NE.ZERO ) THEN J = J + 2 ELSE J = J + 1 END IF GO TO 30 40 CONTINUE IWORK( Q+1 ) = N + 1 PQ = P*( Q-P-1 ) * IF( NOTRAN ) THEN * * Solve (I, J) - subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1, ..., 1; J = 1, 2, ..., Q * SCALE = ONE SCALOC = ONE DO 120 J = P + 2, Q JS = IWORK( J ) JSP1 = JS + 1 JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 110 I = P, 1, -1 * IS = IWORK( I ) ISP1 = IS + 1 IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 ZDIM = MB*NB*2 * IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 2-by-2 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = D( IS, IS ) Z( 1, 2 ) = -B( JS, JS ) Z( 2, 2 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = F( IS, JS ) * * Solve Z * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * IF( IJOB.EQ.0 ) THEN CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 50 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 50 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) F( IS, JS ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN ALPHA = -RHS( 1 ) CALL SAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), $ 1 ) CALL SAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), $ 1 ) END IF IF( J.LT.Q ) THEN CALL SAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL SAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN * * Build a 4-by-4 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = ZERO Z( 3, 1 ) = D( IS, IS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = ZERO Z( 2, 2 ) = A( IS, IS ) Z( 3, 2 ) = ZERO Z( 4, 2 ) = D( IS, IS ) * Z( 1, 3 ) = -B( JS, JS ) Z( 2, 3 ) = -B( JS, JSP1 ) Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = -E( JS, JSP1 ) * Z( 1, 4 ) = -B( JSP1, JS ) Z( 2, 4 ) = -B( JSP1, JSP1 ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( IS, JSP1 ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( IS, JSP1 ) * * Solve Z * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * IF( IJOB.EQ.0 ) THEN CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 60 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 60 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( IS, JSP1 ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( IS, JSP1 ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL SGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), $ 1, C( 1, JS ), LDC ) CALL SGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), $ 1, F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL SAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL SAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) CALL SAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL SAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 4-by-4 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( ISP1, IS ) Z( 3, 1 ) = D( IS, IS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = A( IS, ISP1 ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 3, 2 ) = D( IS, ISP1 ) Z( 4, 2 ) = D( ISP1, ISP1 ) * Z( 1, 3 ) = -B( JS, JS ) Z( 2, 3 ) = ZERO Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = -B( JS, JS ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( ISP1, JS ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( ISP1, JS ) * * Solve Z * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 70 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( ISP1, JS ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( ISP1, JS ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL SGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) CALL SGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) END IF IF( J.LT.Q ) THEN CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1, $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1, $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN * * Build an 8-by-8 system Z * x = RHS * CALL SLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( ISP1, IS ) Z( 5, 1 ) = D( IS, IS ) * Z( 1, 2 ) = A( IS, ISP1 ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 5, 2 ) = D( IS, ISP1 ) Z( 6, 2 ) = D( ISP1, ISP1 ) * Z( 3, 3 ) = A( IS, IS ) Z( 4, 3 ) = A( ISP1, IS ) Z( 7, 3 ) = D( IS, IS ) * Z( 3, 4 ) = A( IS, ISP1 ) Z( 4, 4 ) = A( ISP1, ISP1 ) Z( 7, 4 ) = D( IS, ISP1 ) Z( 8, 4 ) = D( ISP1, ISP1 ) * Z( 1, 5 ) = -B( JS, JS ) Z( 3, 5 ) = -B( JS, JSP1 ) Z( 5, 5 ) = -E( JS, JS ) Z( 7, 5 ) = -E( JS, JSP1 ) * Z( 2, 6 ) = -B( JS, JS ) Z( 4, 6 ) = -B( JS, JSP1 ) Z( 6, 6 ) = -E( JS, JS ) Z( 8, 6 ) = -E( JS, JSP1 ) * Z( 1, 7 ) = -B( JSP1, JS ) Z( 3, 7 ) = -B( JSP1, JSP1 ) Z( 7, 7 ) = -E( JSP1, JSP1 ) * Z( 2, 8 ) = -B( JSP1, JS ) Z( 4, 8 ) = -B( JSP1, JSP1 ) Z( 8, 8 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * K = 1 II = MB*NB + 1 DO 80 JJ = 0, NB - 1 CALL SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) K = K + MB II = II + MB 80 CONTINUE * * Solve Z * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 90 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * K = 1 II = MB*NB + 1 DO 100 JJ = 0, NB - 1 CALL SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) CALL SCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) K = K + MB II = II + MB 100 CONTINUE * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, $ C( 1, JS ), LDC ) CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN K = MB*NB + 1 CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), $ MB, B( JS, JE+1 ), LDB, ONE, $ C( IS, JE+1 ), LDC ) CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), $ MB, E( JS, JE+1 ), LDE, ONE, $ F( IS, JE+1 ), LDF ) END IF * END IF * 110 CONTINUE 120 CONTINUE ELSE * * Solve (I, J) - subsystem * A(I, I)**T * R(I, J) + D(I, I)**T * L(J, J) = C(I, J) * R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 * SCALE = ONE SCALOC = ONE DO 200 I = 1, P * IS = IWORK( I ) ISP1 = IS + 1 IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 DO 190 J = Q, P + 2, -1 * JS = IWORK( J ) JSP1 = JS + 1 JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 ZDIM = MB*NB*2 IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 2-by-2 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = -B( JS, JS ) Z( 1, 2 ) = D( IS, IS ) Z( 2, 2 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = F( IS, JS ) * * Solve Z**T * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 130 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 130 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) F( IS, JS ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN ALPHA = RHS( 1 ) CALL SAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), $ LDF ) ALPHA = RHS( 2 ) CALL SAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), $ LDF ) END IF IF( I.LT.P ) THEN ALPHA = -RHS( 1 ) CALL SAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, $ C( IE+1, JS ), 1 ) ALPHA = -RHS( 2 ) CALL SAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, $ C( IE+1, JS ), 1 ) END IF * ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN * * Build a 4-by-4 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = ZERO Z( 3, 1 ) = -B( JS, JS ) Z( 4, 1 ) = -B( JSP1, JS ) * Z( 1, 2 ) = ZERO Z( 2, 2 ) = A( IS, IS ) Z( 3, 2 ) = -B( JS, JSP1 ) Z( 4, 2 ) = -B( JSP1, JSP1 ) * Z( 1, 3 ) = D( IS, IS ) Z( 2, 3 ) = ZERO Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = D( IS, IS ) Z( 3, 4 ) = -E( JS, JSP1 ) Z( 4, 4 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( IS, JSP1 ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( IS, JSP1 ) * * Solve Z**T * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 140 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( IS, JSP1 ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( IS, JSP1 ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL SAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, $ F( IS, 1 ), LDF ) CALL SAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, $ F( IS, 1 ), LDF ) CALL SAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, $ F( IS, 1 ), LDF ) CALL SAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL SGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) CALL SGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 4-by-4 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( IS, ISP1 ) Z( 3, 1 ) = -B( JS, JS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = A( ISP1, IS ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 3, 2 ) = ZERO Z( 4, 2 ) = -B( JS, JS ) * Z( 1, 3 ) = D( IS, IS ) Z( 2, 3 ) = D( IS, ISP1 ) Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = D( ISP1, ISP1 ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( ISP1, JS ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( ISP1, JS ) * * Solve Z**T * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 150 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( ISP1, JS ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( ISP1, JS ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL SGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), $ 1, F( IS, 1 ), LDF ) CALL SGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), $ 1, F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL SGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), $ 1 ) CALL SGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), $ 1 ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN * * Build an 8-by-8 system Z**T * x = RHS * CALL SLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( IS, ISP1 ) Z( 5, 1 ) = -B( JS, JS ) Z( 7, 1 ) = -B( JSP1, JS ) * Z( 1, 2 ) = A( ISP1, IS ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 6, 2 ) = -B( JS, JS ) Z( 8, 2 ) = -B( JSP1, JS ) * Z( 3, 3 ) = A( IS, IS ) Z( 4, 3 ) = A( IS, ISP1 ) Z( 5, 3 ) = -B( JS, JSP1 ) Z( 7, 3 ) = -B( JSP1, JSP1 ) * Z( 3, 4 ) = A( ISP1, IS ) Z( 4, 4 ) = A( ISP1, ISP1 ) Z( 6, 4 ) = -B( JS, JSP1 ) Z( 8, 4 ) = -B( JSP1, JSP1 ) * Z( 1, 5 ) = D( IS, IS ) Z( 2, 5 ) = D( IS, ISP1 ) Z( 5, 5 ) = -E( JS, JS ) * Z( 2, 6 ) = D( ISP1, ISP1 ) Z( 6, 6 ) = -E( JS, JS ) * Z( 3, 7 ) = D( IS, IS ) Z( 4, 7 ) = D( IS, ISP1 ) Z( 5, 7 ) = -E( JS, JSP1 ) Z( 7, 7 ) = -E( JSP1, JSP1 ) * Z( 4, 8 ) = D( ISP1, ISP1 ) Z( 6, 8 ) = -E( JS, JSP1 ) Z( 8, 8 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * K = 1 II = MB*NB + 1 DO 160 JJ = 0, NB - 1 CALL SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) K = K + MB II = II + MB 160 CONTINUE * * * Solve Z**T * x = RHS * CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 170 K = 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 170 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * K = 1 II = MB*NB + 1 DO 180 JJ = 0, NB - 1 CALL SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) CALL SCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) K = K + MB II = II + MB 180 CONTINUE * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, $ F( IS, 1 ), LDF ) CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, $ ONE, C( IE+1, JS ), LDC ) CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, $ ONE, C( IE+1, JS ), LDC ) END IF * END IF * 190 CONTINUE 200 CONTINUE * END IF RETURN * * End of STGSY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stgsyl.f000066400000000000000000000541341522610125300263060ustar00rootroot00000000000000*> \brief \b STGSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STGSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ LWORK, M, N * REAL DIF, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STGSYL solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> where R and L are unknown m-by-n matrices, (A, D), (B, E) and *> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, *> respectively, with real entries. (A, D) and (B, E) must be in *> generalized (real) Schur canonical form, i.e. A, B are upper quasi *> triangular and D, E are upper triangular. *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output *> scaling factor chosen to avoid overflow. *> *> In matrix notation (1) is equivalent to solve Zx = scale b, where *> Z is defined as *> *> Z = [ kron(In, A) -kron(B**T, Im) ] (2) *> [ kron(In, D) -kron(E**T, Im) ]. *> *> Here Ik is the identity matrix of size k and X**T is the transpose of *> X. kron(X, Y) is the Kronecker product between the matrices X and Y. *> *> If TRANS = 'T', STGSYL solves the transposed system Z**T*y = scale*b, *> which is equivalent to solve for R and L in *> *> A**T * R + D**T * L = scale * C (3) *> R * B**T + L * E**T = scale * -F *> *> This case (TRANS = 'T') is used to compute an one-norm-based estimate *> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) *> and (B,E), using SLACON. *> *> If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate *> of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the *> reciprocal of the smallest singular value of Z. See [1-2] for more *> information. *> *> This is a level 3 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T', solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: The functionality of 0 and 3. *> =2: The functionality of 0 and 4. *> =3: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (look ahead strategy IJOB = 1 is used). *> =4: Only an estimate of Dif[(A,D), (B,E)] is computed. *> ( SGECON on sub-systems is used ). *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrices A and D, and the row dimension of *> the matrices C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices B and E, and the column dimension *> of the matrices C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA, M) *> The upper quasi triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB, N) *> The upper quasi triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is REAL array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, C has been overwritten by *> the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is REAL array, dimension (LDD, M) *> The upper triangular matrix D. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the array D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is REAL array, dimension (LDE, N) *> The upper triangular matrix E. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the array E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is REAL array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, F has been overwritten by *> the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is REAL *> On exit DIF is the reciprocal of a lower bound of the *> reciprocal of the Dif-function, i.e. DIF is an upper bound of *> Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). *> IF IJOB = 0 or TRANS = 'T', DIF is not touched. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> On exit SCALE is the scaling factor in (1) or (3). *> If 0 < SCALE < 1, C and F hold the solutions R and L, resp., *> to a slightly perturbed system but the input matrices A, B, D *> and E have not been changed. If SCALE = 0, C and F hold the *> solutions R and L, respectively, to the homogeneous system *> with C = F = 0. Normally, SCALE = 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. LWORK > = 1. *> If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*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] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+N+6) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: successful exit *> <0: If INFO = -i, the i-th argument had an illegal value. *> >0: (A, D) and (B, E) have common or close eigenvalues. *> \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 Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, *> No 1, 1996. *> *> [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester *> Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. *> Appl., 15(4):1045-1060, 1994 *> *> [3] B. Kagstrom and L. Westin, Generalized Schur Methods with *> Condition Estimators for Solving the Generalized Sylvester *> Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, *> July 1989, pp 745-751. *> \endverbatim *> * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, $ LWORK, M, N REAL DIF, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ), $ WORK( * ) * .. * * ===================================================================== * Replaced various illegal calls to SCOPY by calls to SLASET. * Sven Hammarling, 1/5/02. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, NOTRAN INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, $ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q REAL DSCALE, DSUM, SCALE2, SCALOC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL SGEMM, SLACPY, SLASET, SSCAL, STGSY2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, REAL, SQRT * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF * IF( INFO.EQ.0 ) THEN IF( NOTRAN ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN LWMIN = MAX( 1, 2*M*N ) ELSE LWMIN = 1 END IF ELSE LWMIN = 1 END IF WORK( 1 ) = LWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'STGSYL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN SCALE = 1 IF( NOTRAN ) THEN IF( IJOB.NE.0 ) THEN DIF = 0 END IF END IF RETURN END IF * * Determine optimal block sizes MB and NB * MB = ILAENV( 2, 'STGSYL', TRANS, M, N, -1, -1 ) NB = ILAENV( 5, 'STGSYL', TRANS, M, N, -1, -1 ) * ISOLVE = 1 IFUNC = 0 IF( NOTRAN ) THEN IF( IJOB.GE.3 ) THEN IFUNC = IJOB - 2 CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN ISOLVE = 2 END IF END IF * IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) $ THEN * DO 30 IROUND = 1, ISOLVE * * Use unblocked Level 2 solver * DSCALE = ZERO DSUM = ONE PQ = 0 CALL STGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, $ IWORK, PQ, INFO ) IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF * IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL SLACPY( 'F', M, N, C, LDC, WORK, M ) CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL SLACPY( 'F', M, N, WORK, M, C, LDC ) CALL SLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 30 CONTINUE * RETURN END IF * * Determine block structure of A * P = 0 I = 1 40 CONTINUE IF( I.GT.M ) $ GO TO 50 P = P + 1 IWORK( P ) = I I = I + MB IF( I.GE.M ) $ GO TO 50 IF( A( I, I-1 ).NE.ZERO ) $ I = I + 1 GO TO 40 50 CONTINUE * IWORK( P+1 ) = M + 1 IF( IWORK( P ).EQ.IWORK( P+1 ) ) $ P = P - 1 * * Determine block structure of B * Q = P + 1 J = 1 60 CONTINUE IF( J.GT.N ) $ GO TO 70 Q = Q + 1 IWORK( Q ) = J J = J + NB IF( J.GE.N ) $ GO TO 70 IF( B( J, J-1 ).NE.ZERO ) $ J = J + 1 GO TO 60 70 CONTINUE * IWORK( Q+1 ) = N + 1 IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) $ Q = Q - 1 * IF( NOTRAN ) THEN * DO 150 IROUND = 1, ISOLVE * * Solve (I, J)-subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1,..., 1; J = 1, 2,..., Q * DSCALE = ZERO DSUM = ONE PQ = 0 SCALE = ONE DO 130 J = P + 2, Q JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 120 I = P, 1, -1 IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 PPQQ = 0 CALL STGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ IWORK( Q+2 ), PPQQ, LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO * PQ = PQ + PPQQ IF( SCALOC.NE.ONE ) THEN DO 80 K = 1, JS - 1 CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 80 CONTINUE DO 90 K = JS, JE CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 ) CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 ) 90 CONTINUE DO 100 K = JS, JE CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) 100 CONTINUE DO 110 K = JE + 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE, $ C( 1, JS ), LDC ) CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE, $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, $ F( IS, JS ), LDF, B( JS, JE+1 ), LDB, $ ONE, C( IS, JE+1 ), LDC ) CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, $ F( IS, JS ), LDF, E( JS, JE+1 ), LDE, $ ONE, F( IS, JE+1 ), LDF ) END IF 120 CONTINUE 130 CONTINUE IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL SLACPY( 'F', M, N, C, LDC, WORK, M ) CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL SLACPY( 'F', M, N, WORK, M, C, LDC ) CALL SLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 150 CONTINUE * ELSE * * Solve transposed (I, J)-subsystem * A(I, I)**T * R(I, J) + D(I, I)**T * L(I, J) = C(I, J) * R(I, J) * B(J, J)**T + L(I, J) * E(J, J)**T = -F(I, J) * for I = 1,2,..., P; J = Q, Q-1,..., 1 * SCALE = ONE DO 210 I = 1, P IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 DO 200 J = Q, P + 2, -1 JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 CALL STGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ IWORK( Q+2 ), PPQQ, LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO IF( SCALOC.NE.ONE ) THEN DO 160 K = 1, JS - 1 CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 160 CONTINUE DO 170 K = JS, JE CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 ) CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 ) 170 CONTINUE DO 180 K = JS, JE CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) 180 CONTINUE DO 190 K = JE + 1, N CALL SSCAL( M, SCALOC, C( 1, K ), 1 ) CALL SSCAL( M, SCALOC, F( 1, K ), 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I, J) and L(I, J) into remaining equation. * IF( J.GT.P+2 ) THEN CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ), $ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ), $ LDF ) CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ), $ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ), $ LDF ) END IF IF( I.LT.P ) THEN CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE, $ C( IE+1, JS ), LDC ) CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE, $ C( IE+1, JS ), LDC ) END IF 200 CONTINUE 210 CONTINUE * END IF * WORK( 1 ) = LWMIN * RETURN * * End of STGSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stplqt.f000066400000000000000000000174051522610125300263100ustar00rootroot00000000000000*> \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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 lower trapezoidal. *> *> The lower trapezoidal matrix B2 consists of the first L columns of a *> M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> [ W ] = [ I ] [ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stplqt2.f000066400000000000000000000212321522610125300263630ustar00rootroot00000000000000*> \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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ I ][ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stpmlqt.f000066400000000000000000000241731522610125300264650ustar00rootroot00000000000000*> \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 November 2017 * *> \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.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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 SLARFB, STPRFB, XERBLA * .. * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stpmqrt.f000066400000000000000000000242431522610125300264710ustar00rootroot00000000000000*> \brief \b STPMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STPMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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 * * 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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CTPQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CTPQRT 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 CTPQRT, stored as a NB-by-K matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \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*NB if SIDE = 'L', or M*NB 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 realOTHERcomputational * *> \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 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 = '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. *> *> 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 STPMQRT( SIDE, TRANS, M, N, K, L, NB, 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, NB, LDT * .. * .. Array Arguments .. REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), $ WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. 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 LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN LDVQ = MAX( 1, N ) 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( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) 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( 'STPMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * DO I = 1, K, NB 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 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 IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB 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 CALL STPRFB( 'L', 'N', '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. TRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 ELSE 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * END IF * RETURN * * End of STPMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stpqrt.f000066400000000000000000000172061522610125300263150ustar00rootroot00000000000000*> \brief \b STPQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STPQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 *> WY representation for Q. *> \endverbatim * * Arguments: * ========== * *> \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, and the order of the *> triangular matrix A. *> N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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 *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (NB*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 realOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 number of blocks is B = ceiling(N/NB), where each *> 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 *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. *> \endverbatim *> * ===================================================================== SUBROUTINE STPQRT( M, N, L, NB, 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, NB * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, LB, MB, IINFO * .. * .. External Subroutines .. EXTERNAL STPQRT2, 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( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STPQRT', -INFO ) RETURN END IF * * Quick return if possible * 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 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF * 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, $ WORK, IB ) END IF END DO RETURN * * End of STPQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stpqrt2.f000066400000000000000000000206321522610125300263740ustar00rootroot00000000000000*> \brief \b STPQRT2 computes a QR 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 STPQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \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, *> 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 upper 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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,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 realOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W^H *> *> where W^H is the conjugate transpose of W and T is the upper triangular *> factor of the block reflector. *> \endverbatim *> * ===================================================================== SUBROUTINE STPQRT2( 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, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STPQRT2', -INFO ) RETURN END IF * * 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) * P = M-L+MIN( L, I ) CALL SLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) ) IF( I.LT.N ) THEN * * W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)] * 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, $ 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 )) 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, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO * DO I = 2, N * * T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I)) * ALPHA = -T( I, 1 ) DO J = 1, I-1 T( J, I ) = ZERO END DO P = MIN( I-1, L ) MP = MIN( M-L+1, M ) NP = MIN( P+1, N ) * * Triangular part of B2 * DO J = 1, P T( J, I ) = ALPHA*B( M-L+J, I ) END DO CALL STRMV( 'U', 'T', 'N', P, B( MP, 1 ), LDB, $ T( 1, I ), 1 ) * * Rectangular part of B2 * 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 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL STRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO * * End of STPQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/stprfb.f000066400000000000000000000623541522610125300262640ustar00rootroot00000000000000*> \brief \b STPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STPRFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * ), * $ 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 *> blocks A and B, either from the left or right. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H^H from the Left *> = 'R': apply H or H^H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'C': apply H^H (Conjugate transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columns *> = 'R': Rows *> \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 order of the matrix T, i.e. the number of elementary *> 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. *> K >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is REAL array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The pentagonal matrix V, which contains the elementary reflectors *> H(1), H(2), ..., H(K). See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is REAL array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= K. *> \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 *> 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. *> 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 *> H*C or H^H*C or C*H or C*H^H. 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, dimension *> (LDWORK,N) if SIDE = 'L', *> (LDWORK,K) if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> 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. * *> \date December 2016 * *> \ingroup realOTHERauxiliary * *> \par Further Details: * ===================== *> *> \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, *> 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] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] *> [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 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. *> *> If DIRECT = 'F' and STOREV = 'C': V = [V1] *> [V2] *> - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) *> *> If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] *> *> - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'C': V = [V2] *> [V1] *> - 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. *> *> If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. *> *> If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. *> *> If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. *> \endverbatim *> * ===================================================================== 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.7.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 DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * * ========================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0, ZERO = 0.0 ) * .. * .. Local Scalars .. INTEGER I, J, MP, NP, KP LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SGEMM, STRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 .OR. L.LT.0 ) RETURN * IF( LSAME( STOREV, 'C' ) ) THEN COLUMN = .TRUE. ROW = .FALSE. ELSE IF ( LSAME( STOREV, 'R' ) ) THEN COLUMN = .FALSE. ROW = .TRUE. ELSE COLUMN = .FALSE. ROW = .FALSE. END IF * IF( LSAME( SIDE, 'L' ) ) THEN LEFT = .TRUE. RIGHT = .FALSE. ELSE IF( LSAME( SIDE, 'R' ) ) THEN LEFT = .FALSE. RIGHT = .TRUE. ELSE LEFT = .FALSE. RIGHT = .FALSE. END IF * IF( LSAME( DIRECT, 'F' ) ) THEN FORWARD = .TRUE. BACKWARD = .FALSE. ELSE IF( LSAME( DIRECT, 'B' ) ) THEN FORWARD = .FALSE. BACKWARD = .TRUE. ELSE FORWARD = .FALSE. BACKWARD = .FALSE. END IF * * --------------------------------------------------------------------------- * IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (M-by-K) * * Form H C or H^H C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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, $ ONE, WORK, LDWORK ) 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, $ 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, 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 ) CALL STRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (N-by-K) * * Form C H or C H^H where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W T W^H or H^H = I - W T^H W^H * * A = A - (A + B V) T or A = A - (A + B V) T^H * B = B - (A + B V) T V^H or B = B - (A + B V) T^H V^H * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V, LDV, ONE, WORK, LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL SGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL SGEMM( 'N', 'T', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, $ V( NP, KP ), LDV, ONE, B( 1, NP ), LDB ) CALL STRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (M-by-K) * [ I ] (K-by-K) * * Form H C or H^H C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO * 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, $ 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 ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * 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, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL SGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL STRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (N-by-K) * [ I ] (K-by-K) * * Form C H or C H^H where C = [ B A ] (B is M-by-N, A is M-by-K) * * H = I - W T W^H or H^H = I - W T^H W^H * * A = A - (A + B V) T or A = A - (A + B V) T^H * B = B - (A + B V) T V^H or B = B - (A + B V) T^H V^H * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL SGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, $ V( NP, 1 ), LDV, ONE, B( 1, NP ), LDB ) CALL SGEMM( 'N', 'T', M, L, K-L, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL STRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-M ) * * Form H C or H^H C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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', '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, $ ONE, WORK, LDWORK ) CALL SGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), 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, $ 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( '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, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL STRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H^H where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W^H T W or H^H = I - W^H T^H W * * A = A - (A + B V^H) T or A = A - (A + B V^H) T^H * B = B - (A + B V^H) T V or B = B - (A + B V^H) T^H V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL STRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, NP ), LDV, $ 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, $ V( KP, 1 ), 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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 ) CALL STRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-M ) * * Form H C or H^H C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO CALL STRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) CALL SGEMM( 'N', 'N', L, N, M-L, ONE, V( KP, MP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL SGEMM( 'N', 'N', K-L, N, M, ONE, V, LDV, B, LDB, $ ZERO, WORK, 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', '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( '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, $ WORK, LDWORK, ONE, B, LDB ) CALL STRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H^H where C = [ B A ] (A is M-by-K, B is M-by-N) * * H = I - W^H T W or H^H = I - W^H T^H W * * A = A - (A + B V^H) T or A = A - (A + B V^H) T^H * B = B - (A + B V^H) T V or B = B - (A + B V^H) T^H V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL STRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) 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 ) * 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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, $ V, LDV, ONE, B, LDB ) CALL STRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * END IF * RETURN * * End of STPRFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/strevc.f000066400000000000000000001076601522610125300262720ustar00rootroot00000000000000*> \brief \b STREVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STREVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STREVC 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. *> \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 (3*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 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 STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, 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 HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, 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 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER ISAMAX REAL SDOT, SLAMCH EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. REAL X( 2, 2 ) * .. * .. 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 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 * * 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( 'STREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * 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) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 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+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the 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+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+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+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+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+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL SCOPY( KI, WORK( 1+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( KI.GT.1 ) $ CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+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 ) 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+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*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+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+N ), 1 ) CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 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+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+N ), 1 ) CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL SCOPY( KI, WORK( 1+N2 ), 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( KI.GT.2 ) THEN CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL SSCAL( N, WORK( KI+N2 ), 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 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 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+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the 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+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+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+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+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+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ SDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+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+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL SCOPY( N-KI+1, WORK( KI+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( KI.LT.N ) $ CALL SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+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 ) * 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+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (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+N ), 1 ) CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 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+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+N ), 1 ) CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), 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+N ), 1 ) CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ SDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ SDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 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+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+N ), 1 ) CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = 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 CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL SCOPY( N-KI+1, WORK( KI+N2 ), 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( KI.LT.N-1 ) THEN CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL SSCAL( N, WORK( KI+1+N2 ), 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 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of STREVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/strexc.f000066400000000000000000000300441522610125300262630ustar00rootroot00000000000000*> \brief \b STREXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STREXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STREXC reorders the real Schur factorization of a real matrix *> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is *> moved to row ILST. *> *> The real Schur form T is reordered by an orthogonal similarity *> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors *> is updated by postmultiplying it with Z. *> *> T must be in Schur canonical form (as returned by SHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] N *> \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 *> \verbatim *> T is REAL array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> Schur canonical form. *> On exit, the reordered upper quasi-triangular matrix, again *> 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] Q *> \verbatim *> Q is REAL array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> orthogonal transformation matrix Z which reorders T. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1, and if *> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> *> Specify the reordering of the diagonal blocks of T. *> The block with row index IFST is moved to row ILST, by a *> sequence of transpositions between adjacent blocks. *> On exit, if IFST pointed on entry to the second row of a *> 2-by-2 block, it is changed to point to the first row; ILST *> always points to the first row of the block in its final *> position (which may differ from its input value by +1 or -1). *> 1 <= IFST <= N; 1 <= ILST <= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is REAL 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 *> = 1: two adjacent blocks were too close to swap (the problem *> is very ill-conditioned); T may have been partially *> reordered, and ILST points to the first row of the *> current position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, 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 COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL WANTQ INTEGER HERE, NBF, NBL, NBNEXT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLAEXC, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test the input arguments. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN 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 ).AND.( N.GT.0 )) THEN INFO = -7 ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of specified block * and find out it is 1 by 1 or 2 by 2. * IF( IFST.GT.1 ) THEN IF( T( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( T( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out it is 1 by 1 or 2 by 2. * IF( ILST.GT.1 ) THEN IF( T( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( T( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF * IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap block with next one below * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( T( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, $ WORK, INFO ) HERE = HERE + 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, $ NBNEXT, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2 by 2 Block did split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, $ WORK, INFO ) HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 * ELSE * HERE = IFST 20 CONTINUE * * Swap block with next one above * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ NBF, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ 1, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, $ WORK, INFO ) HERE = HERE - 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2 by 2 Block did split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, $ WORK, INFO ) HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE * RETURN * * End of STREXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/strsen.f000066400000000000000000000434601522610125300262770ustar00rootroot00000000000000*> \brief \b STRSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STRSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL S, SEP * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STRSEN reorders the real Schur factorization of a real matrix *> A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in *> the leading diagonal blocks of the upper quasi-triangular matrix T, *> and the leading columns of Q form an orthonormal basis of the *> corresponding right invariant subspace. *> *> Optionally the routine computes the reciprocal condition numbers of *> the cluster of eigenvalues and/or the invariant subspace. *> *> T must be in Schur canonical form (as returned by SHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (S) or the invariant subspace (SEP): *> = 'N': none; *> = 'E': for eigenvalues only (S); *> = 'V': for invariant subspace only (SEP); *> = 'B': for both eigenvalues and invariant subspace (S and *> SEP). *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select a real eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. To select a complex conjugate pair of eigenvalues *> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, *> either SELECT(j) or SELECT(j+1) or both must be set to *> .TRUE.; a complex conjugate pair of eigenvalues must be *> either both included in the cluster or both excluded. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is REAL array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> canonical form. *> On exit, T is overwritten by the reordered matrix T, again in *> Schur canonical form, with the selected eigenvalues in the *> leading diagonal blocks. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> orthogonal transformation matrix which reorders T; the *> leading M columns of Q form an orthonormal basis for the *> specified invariant subspace. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is REAL array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is REAL array, dimension (N) *> *> The real and imaginary parts, respectively, of the reordered *> eigenvalues of T. The eigenvalues are stored in the same *> order as on the diagonal of T, with WR(i) = T(i,i) and, if *> T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and *> WI(i+1) = -WI(i). Note that if a complex eigenvalue is *> sufficiently ill-conditioned, then its value may differ *> significantly from its value before reordering. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified invariant subspace. *> 0 < = M <= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is REAL *> If JOB = 'E' or 'B', S is a lower bound on the reciprocal *> condition number for the selected cluster of eigenvalues. *> S cannot underestimate the true reciprocal condition number *> by more than a factor of sqrt(N). If M = 0 or N, S = 1. *> If JOB = 'N' or 'V', S is not referenced. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is REAL *> If JOB = 'V' or 'B', SEP is the estimated reciprocal *> condition number of the specified invariant subspace. If *> M = 0 or N, SEP = norm(T). *> If JOB = 'N' or 'E', SEP is not referenced. *> \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 JOB = 'N', LWORK >= max(1,N); *> if JOB = 'E', LWORK >= max(1,M*(N-M)); *> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-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] 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 JOB = 'N' or 'E', LIWORK >= 1; *> if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). *> *> 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 *> = 1: reordering of T failed because some eigenvalues are too *> close to separate (the problem is very ill-conditioned); *> T may have been partially reordered, and WR and WI *> contain the eigenvalues in the same order as in T; S and *> SEP (if requested) are set to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup realOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> STRSEN first collects the selected eigenvalues by computing an *> orthogonal transformation Z to move them to the top left corner of T. *> In other words, the selected eigenvalues are the eigenvalues of T11 *> in: *> *> Z**T * T * Z = ( T11 T12 ) n1 *> ( 0 T22 ) n2 *> n1 n2 *> *> where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns *> of Z span the specified invariant subspace of T. *> *> If T has been obtained from the real Schur factorization of a matrix *> A = Q*T*Q**T, then the reordered real Schur factorization of A is given *> by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span *> the corresponding invariant subspace of A. *> *> The reciprocal condition number of the average of the eigenvalues of *> T11 may be returned in S. S lies between 0 (very badly conditioned) *> and 1 (very well conditioned). It is computed as follows. First we *> compute R so that *> *> P = ( I R ) n1 *> ( 0 0 ) n2 *> n1 n2 *> *> is the projector on the invariant subspace associated with T11. *> R is the solution of the Sylvester equation: *> *> T11*R - R*T22 = T12. *> *> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote *> the two-norm of M. Then S is computed as the lower bound *> *> (1 + F-norm(R)**2)**(-1/2) *> *> on the reciprocal of 2-norm(P), the true reciprocal condition number. *> S cannot underestimate 1 / 2-norm(P) by more than a factor of *> sqrt(N). *> *> An approximate error bound for the computed average of the *> eigenvalues of T11 is *> *> EPS * norm(T) / S *> *> where EPS is the machine precision. *> *> The reciprocal condition number of the right invariant subspace *> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. *> SEP is defined as the separation of T11 and T22: *> *> sep( T11, T22 ) = sigma-min( C ) *> *> where sigma-min(C) is the smallest singular value of the *> n1*n2-by-n1*n2 matrix *> *> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) *> *> I(m) is an m by m identity matrix, and kprod denotes the Kronecker *> product. We estimate sigma-min(C) by the reciprocal of an estimate of *> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) *> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). *> *> When SEP is small, small changes in T can cause large changes in *> the invariant subspace. An approximate bound on the maximum angular *> error in the computed right invariant subspace is *> *> EPS * norm(T) / SEP *> \endverbatim *> * ===================================================================== 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.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 COMPQ, JOB INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N REAL S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), $ WR( * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS, $ WANTSP INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, $ NN REAL EST, RNORM, SCALE * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME REAL SLANGE EXTERNAL LSAME, SLANGE * .. * .. External Subroutines .. EXTERNAL SLACN2, SLACPY, STREXC, STRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE * * Set M to the dimension of the specified invariant subspace, * and test LWORK and LIWORK. * M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( T( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * IF( WANTSP ) THEN LWMIN = MAX( 1, 2*NN ) LIWMIN = MAX( 1, NN ) ELSE IF( LSAME( JOB, 'N' ) ) THEN LWMIN = MAX( 1, N ) LIWMIN = 1 ELSE IF( LSAME( JOB, 'E' ) ) THEN LWMIN = MAX( 1, NN ) LIWMIN = 1 END IF * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -15 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -17 END IF END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'STRSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = SLANGE( '1', N, N, T, LDT, WORK ) GO TO 40 END IF * * Collect the selected blocks at the top-left corner of T. * KS = 0 PAIR = .FALSE. DO 20 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( T( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * IERR = 0 KK = K IF( K.NE.KS ) $ CALL STREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, $ IERR ) IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN * * Blocks too close to swap: exit. * INFO = 1 IF( WANTS ) $ S = ZERO IF( WANTSP ) $ SEP = ZERO GO TO 40 END IF IF( PAIR ) $ KS = KS + 1 END IF END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL SLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = SLANGE( 'F', N1, N2, WORK, N1, WORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL SLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11**T*R - R*T22**T = scale*X. * CALL STRSYL( 'T', 'T', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Store the output eigenvalues in WR and WI. * DO 50 K = 1, N WR( K ) = T( K, K ) WI( K ) = ZERO 50 CONTINUE DO 60 K = 1, N - 1 IF( T( K+1, K ).NE.ZERO ) THEN WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* $ SQRT( ABS( T( K+1, K ) ) ) WI( K+1 ) = -WI( K ) END IF 60 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of STRSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/strsyl.f000066400000000000000000001057111522610125300263170ustar00rootroot00000000000000*> \brief \b STRSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STRSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * REAL SCALE * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STRSYL solves the real Sylvester matrix equation: *> *> op(A)*X + X*op(B) = scale*C or *> op(A)*X - X*op(B) = scale*C, *> *> where op(A) = A or A**T, and A and B are both upper quasi- *> triangular. A is M-by-M and B is N-by-N; the right hand side C and *> the solution X are M-by-N; and scale is an output scale factor, set *> <= 1 to avoid overflow in X. *> *> A and B must be in Schur canonical form (as returned by SHSEQR), that *> is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; *> each 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANA *> \verbatim *> TRANA is CHARACTER*1 *> Specifies the option op(A): *> = 'N': op(A) = A (No transpose) *> = 'T': op(A) = A**T (Transpose) *> = 'C': op(A) = A**H (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] TRANB *> \verbatim *> TRANB is CHARACTER*1 *> Specifies the option op(B): *> = 'N': op(B) = B (No transpose) *> = 'T': op(B) = B**T (Transpose) *> = 'C': op(B) = B**H (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> Specifies the sign in the equation: *> = +1: solve op(A)*X + X*op(B) = scale*C *> = -1: solve op(A)*X - X*op(B) = scale*C *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrix A, and the number of rows in the *> matrices X and C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B, and the number of columns in the *> matrices X and C. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,M) *> The upper quasi-triangular matrix A, in Schur canonical form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB,N) *> The upper quasi-triangular matrix B, in Schur canonical form. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is REAL array, dimension (LDC,N) *> On entry, the M-by-N right hand side matrix C. *> On exit, C is overwritten by the solution matrix X. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M) *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is REAL *> The scale factor, scale, set <= 1 to avoid overflow in X. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: A and B have common or very close eigenvalues; perturbed *> values were used to solve the equation (but the matrices *> A and B are unchanged). *> \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 STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, 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 TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N REAL SCALE * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT REAL A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM, SUML, SUMR, XNORM * .. * .. Local Arrays .. REAL DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME REAL SDOT, SLAMCH, SLANGE EXTERNAL LSAME, SDOT, SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SLABAD, SLALN2, SLASY2, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STRSYL', -INFO ) RETURN END IF * * Quick return if possible * SCALE = ONE IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*REAL( M*N ) / EPS BIGNUM = ONE / SMLNUM * SMIN = MAX( SMLNUM, EPS*SLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*SLANGE( 'M', N, N, B, LDB, DUM ) ) * SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * * Start column loop (index = L) * L1 (L2) : column index of the first (first) row of X(K,L). * LNEXT = 1 DO 70 L = 1, N IF( L.LT.LNEXT ) $ GO TO 70 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L). * KNEXT = M DO 60 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 60 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 20 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 20 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .FALSE., .FALSE., ISGN, 2, 2, $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 50 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 50 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 60 CONTINUE * 70 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A**T *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = 1 DO 130 L = 1, N IF( L.LT.LNEXT ) $ GO TO 130 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 120 K = 1, M IF( K.LT.KNEXT ) $ GO TO 120 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 80 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 80 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 90 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 110 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 120 CONTINUE 130 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A**T*X + ISGN*X*B**T = scale*C. * * The (K,L)th block of X is determined starting from * top-right corner column by column by * * A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) * * Where * K-1 N * R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. * I=1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 190 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 190 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 180 K = 1, M IF( K.LT.KNEXT ) $ GO TO 180 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 140 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 150 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 160 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 160 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN(L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 170 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 170 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 180 CONTINUE 190 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B**T = scale*C. * * The (K,L)th block of X is determined starting from * bottom-right corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. * I=K+1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 250 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 250 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = M DO 240 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 240 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( M-K1, A( K1, MIN(K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 200 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 200 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 210 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 210 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 220 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 220 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 230 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 230 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 240 CONTINUE 250 CONTINUE * END IF * RETURN * * End of STRSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/strti2.f000066400000000000000000000134051522610125300262040ustar00rootroot00000000000000*> \brief \b STRTI2 computes the inverse of a triangular matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download STRTI2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> STRTI2 computes the inverse of a real upper or lower triangular *> matrix. *> *> This is the Level 2 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit 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 triangular matrix A. If UPLO = 'U', the *> leading n by n upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. If DIAG = 'U', the *> diagonal elements of A are also not referenced and are *> assumed to be 1. *> *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J REAL AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SSCAL, STRMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, '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.NE.0 ) THEN CALL XERBLA( 'STRTI2', -INFO ) RETURN END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL STRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL SSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE * * Compute inverse of lower triangular matrix. * DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL STRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL SSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF * RETURN * * End of STRTI2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/xerbla.f000066400000000000000000000050311522610125300262260ustar00rootroot00000000000000*> \brief \b XERBLA * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download XERBLA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. * CHARACTER*(*) SRNAME * INTEGER INFO * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> XERBLA is an error handler for the LAPACK routines. *> It is called by an LAPACK routine if an input parameter has an *> invalid value. A message is printed and execution stops. *> *> Installers may consider modifying the STOP statement in order to *> call system-specific exception-handling facilities. *> \endverbatim * * Arguments: * ========== * *> \param[in] SRNAME *> \verbatim *> SRNAME is CHARACTER*(*) *> The name of the routine which called XERBLA. *> \endverbatim *> *> \param[in] INFO *> \verbatim *> INFO is INTEGER *> The position of the invalid parameter in the parameter list *> of the calling routine. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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*(*) SRNAME INTEGER INFO * .. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LEN_TRIM * .. * .. Executable Statements .. * WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO * STOP * 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zaxpby.f000066400000000000000000000060251522610125300262720ustar00rootroot00000000000000*> \brief \b ZAXPY * * =========== DOCUMENTATION =========== * * 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 * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZAXPY constant times a vector plus a vector. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> number of elements in input vector(s) *> \endverbatim *> *> \param[in] ZA *> \verbatim *> ZA is COMPLEX*16 *> On entry, ZA specifies the scalar alpha. *> \endverbatim *> *> \param[in] ZX *> \verbatim *> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> storage spacing between elements of ZX *> \endverbatim *> *> \param[in,out] ZY *> \verbatim *> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> storage spacing between elements of ZY *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup complex16_blas_level1 * *> \par Further Details: * ===================== *> *> \verbatim *> *> jack dongarra, 3/11/78. *> modified 12/3/93, array(1) declarations changed to array(*) *> \endverbatim *> * ===================================================================== SUBROUTINE ZAXPBY(N,ZA,ZX,INCX,ZB,ZY,INCY) * * -- Reference BLAS level1 routine (version 3.8.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. COMPLEX*16 ZA,ZB INTEGER INCX,INCY,N * .. * .. Array Arguments .. COMPLEX*16 ZX(*),ZY(*) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I,IX,IY * .. * .. External Functions .. DOUBLE PRECISION DCABS1 EXTERNAL DCABS1 * .. IF (N.LE.0) RETURN IF (DCABS1(ZA).EQ.0.0d0) RETURN IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN * * code for both increments equal to 1 * DO I = 1,N ZY(I) = ZB * ZY(I) + ZA*ZX(I) END DO ELSE * * code for unequal increments or equal increments * not equal to 1 * IX = 1 IY = 1 IF (INCX.LT.0) IX = (-N+1)*INCX + 1 IF (INCY.LT.0) IY = (-N+1)*INCY + 1 DO I = 1,N ZY(IY) = ZB * ZY(IY) + ZA*ZX(IX) IX = IX + INCX IY = IY + INCY END DO END IF * RETURN END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgebak.f000066400000000000000000000161571522610125300262270ustar00rootroot00000000000000*> \brief \b ZGEBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION SCALE( * ) * COMPLEX*16 V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEBAK forms the right or left eigenvectors of a complex general *> matrix by backward transformation on the computed eigenvectors of the *> balanced matrix output by ZGEBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N', do nothing, return immediately; *> = 'P', do backward transformation for permutation only; *> = 'S', do backward transformation for scaling only; *> = 'B', do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to ZGEBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by ZGEBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutation and scaling factors, as returned *> by ZGEBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is COMPLEX*16 array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by ZHSEIN or ZTREVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= 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 complex16GEcomputational * * ===================================================================== SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ) COMPLEX*16 V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K DOUBLE PRECISION S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL ZDSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL ZDSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of ZGEBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgebal.f000066400000000000000000000246401522610125300262240ustar00rootroot00000000000000*> \brief \b ZGEBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION SCALE( * ) * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEBAL balances a general complex matrix A. This involves, first, *> permuting A by a similarity transformation to isolate eigenvalues *> in the first 1 to ILO-1 and last IHI+1 to N elements on the *> diagonal; and second, applying a diagonal similarity transformation *> to rows and columns ILO to IHI to make the rows and columns as *> close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrix, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A: *> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 *> for i = 1,...,N; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A is not referenced. *> 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] ILO *> \verbatim *> \endverbatim *> *> \param[out] IHI *> \verbatim *> ILO and IHI are set to INTEGER such that on exit *> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied to *> A. If P(j) is the index of the row and column interchanged *> with row and column j and D(j) is the scaling factor *> applied to row and column j, then *> SCALE(j) = P(j) for j = 1,...,ILO-1 *> = D(j) for j = ILO,...,IHI *> = P(j) for j = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-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 complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The permutations consist of row and column interchanges which put *> the matrix in the form *> *> ( T1 X Y ) *> P A P = ( 0 B Z ) *> ( 0 0 T2 ) *> *> where T1 and T2 are upper triangular matrices whose eigenvalues lie *> along the diagonal. The column indices ILO and IHI mark the starting *> and ending columns of the submatrix B. Balancing consists of applying *> a diagonal similarity transformation inv(D) * B * D to make the *> 1-norms of each row of B and its corresponding column nearly equal. *> The output matrix is *> *> ( T1 X*D Y ) *> ( 0 inv(D)*B*D inv(D)*Z ). *> ( 0 0 T2 ) *> *> Information about the permutations P and the diagonal matrix D is *> returned in the vector SCALE. *> *> This subroutine is based on the EISPACK routine CBAL. *> *> Modified by Tzu-Yi Chen, Computer Science Division, University of *> California at Berkeley, USA *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, 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 JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ) COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 * .. * .. External Functions .. LOGICAL DISNAN, LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2 * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, MIN * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) 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( 'ZGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE. $ ZERO )GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE. $ ZERO )GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L * C = DZNRM2( L-K+1, A( K, I ), 1 ) R = DZNRM2( L-K+1, A( I, K ), LDA ) ICA = IZAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IZAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 IF( DISNAN( C+F+CA+R+G+RA ) ) THEN * * Exit if NaN to avoid infinite loop * INFO = -3 CALL XERBLA( 'ZGEBAL', -INFO ) RETURN END IF F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) CALL ZDSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of ZGEBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgebd2.f000066400000000000000000000243031522610125300261310ustar00rootroot00000000000000*> \brief \b ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEBD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEBD2 reduces a complex general m by n matrix A to upper or lower *> real bidiagonal form B by a unitary transformation: Q**H * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in 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 general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the unitary matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the unitary matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the unitary matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the unitary matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix P. See Further Details. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (max(M,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 June 2017 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in *> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in *> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, v and u are complex vectors; *> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); *> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); *> tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 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 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * ALPHA = A( I, I ) CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = ALPHA A( I, I ) = ONE * * Apply H(i)**H to A(i:m,i+1:n) from the left * IF( I.LT.N ) $ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL ZLACGV( N-I, A( I, I+1 ), LDA ) ALPHA = A( I, I+1 ) CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, $ TAUP( I ) ) E( I ) = ALPHA A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) A( I, I+1 ) = E( I ) ELSE TAUP( I ) = ZERO END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) ALPHA = A( I, I ) CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = ALPHA A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * ALPHA = A( I+1, I ) CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Apply H(i)**H to A(i+1:m,i+1:n) from the left * CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1, $ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, $ WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of ZGEBD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgebrd.f000066400000000000000000000257401522610125300262370ustar00rootroot00000000000000*> \brief \b ZGEBRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEBRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEBRD reduces a general complex M-by-N matrix A to upper or lower *> bidiagonal form B by a unitary transformation: Q**H * A * P = B. *> *> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in 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 general matrix to be reduced. *> On exit, *> if m >= n, the diagonal and the first superdiagonal are *> overwritten with the upper bidiagonal matrix B; the *> elements below the diagonal, with the array TAUQ, represent *> the unitary matrix Q as a product of elementary *> reflectors, and the elements above the first superdiagonal, *> with the array TAUP, represent the unitary matrix P as *> a product of elementary reflectors; *> if m < n, the diagonal and the first subdiagonal are *> overwritten with the lower bidiagonal matrix B; the *> elements below the first subdiagonal, with the array TAUQ, *> represent the unitary matrix Q as a product of *> elementary reflectors, and the elements above the diagonal, *> with the array TAUP, represent the unitary matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (min(M,N)-1) *> The off-diagonal elements of the bidiagonal matrix B: *> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; *> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix P. See Further Details. *> \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 >= max(1,M,N). *> For optimum performance LWORK >= (M+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 November 2017 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> If m >= n, *> *> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in *> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in *> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, *> *> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The contents of A on exit are illustrated by the following examples: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) *> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) *> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) *> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) *> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) *> ( v1 v2 v3 v4 v5 ) *> *> where d and e denote diagonal and off-diagonal elements of B, vi *> denotes an element of the vector defining H(i), and ui an element of *> the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX, WS * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = DBLE( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 ) IF( LWORK.GE.( M+N )*NBMIN ) THEN NB = LWORK / ( M+N ) ELSE NB = 1 NX = MINMN END IF END IF END IF ELSE NX = MINMN END IF * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+ib-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, $ WORK( LDWRKX*NB+1 ), LDWRKY ) * * Update the trailing submatrix A(i+ib:m,i+ib:n), using * an update of the form A := A - V*Y**H - X*U**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1, $ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA, $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, $ A( I+NB, I+NB ), LDA ) CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 10 J = I, I + NB - 1 A( J, J ) = D( J ) A( J, J+1 ) = E( J ) 10 CONTINUE ELSE DO 20 J = I, I + NB - 1 A( J, J ) = D( J ) A( J+1, J ) = E( J ) 20 CONTINUE END IF 30 CONTINUE * * Use unblocked code to reduce the remainder of the matrix * CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, IINFO ) WORK( 1 ) = WS RETURN * * End of ZGEBRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgees.f000066400000000000000000000320651522610125300260750ustar00rootroot00000000000000*> \brief ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELECT * EXTERNAL SELECT * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEES computes for an N-by-N complex nonsymmetric matrix A, the *> eigenvalues, the Schur form T, and, optionally, the matrix of Schur *> vectors Z. This gives the Schur factorization A = Z*T*(Z**H). *> *> Optionally, it also orders the eigenvalues on the diagonal of the *> Schur form so that selected eigenvalues are at the top left. *> The leading columns of Z then form an orthonormal basis for the *> invariant subspace corresponding to the selected eigenvalues. *> *> A complex matrix is in Schur form if it is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVS *> \verbatim *> JOBVS is CHARACTER*1 *> = 'N': Schur vectors are not computed; *> = 'V': Schur vectors are computed. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the Schur form. *> = 'N': Eigenvalues are not ordered: *> = 'S': Eigenvalues are ordered (see SELECT). *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> 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. *> IF SORT = 'N', SELECT is not referenced. *> The eigenvalue W(j) is selected if SELECT(W(j)) is true. *> \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 N-by-N matrix A. *> On exit, A has been overwritten by its Schur form T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues for which *> SELECT is true. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX*16 array, dimension (N) *> W contains the computed eigenvalues, in the same order that *> they appear on the diagonal of the output Schur form T. *> \endverbatim *> *> \param[out] VS *> \verbatim *> VS is COMPLEX*16 array, dimension (LDVS,N) *> If JOBVS = 'V', VS contains the unitary matrix Z of Schur *> vectors. *> If JOBVS = 'N', VS is not referenced. *> \endverbatim *> *> \param[in] LDVS *> \verbatim *> LDVS is INTEGER *> The leading dimension of the array VS. LDVS >= 1; if *> JOBVS = 'V', LDVS >= 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 dimension of the array WORK. LWORK >= max(1,2*N). *> For good performance, LWORK must generally be larger. *> *> 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 (N) *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \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 i is *> <= N: the QR algorithm failed to compute all the *> eigenvalues; elements 1:ILO-1 and i+1:N of W *> contain those eigenvalues which have converged; *> if JOBVS = 'V', VS contains the matrix which *> reduces A to its partially converged Schur form. *> = N+1: the eigenvalues could not be reordered because *> some eigenvalues were too close to separate (the *> problem is very ill-conditioned); *> = N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Schur form no longer satisfy *> SELECT = .TRUE.. This could also be caused by *> underflow due to scaling. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEeigen * * ===================================================================== SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, $ LDVS, WORK, LWORK, RWORK, BWORK, 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 JOBVS, SORT INTEGER INFO, LDA, LDVS, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) * .. * .. Function Arguments .. LOGICAL SELECT EXTERNAL SELECT * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTST, WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, $ ITAU, IWRK, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN INFO = -10 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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. * HSWORK refers to the workspace preferred by ZHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) MINWRK = 2*N * CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS, $ WORK, -1, IEVAL ) HSWORK = WORK( 1 ) * IF( .NOT.WANTVS ) THEN MAXWRK = MAX( MAXWRK, HSWORK ) ELSE MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', $ ' ', N, 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, HSWORK ) END IF END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Permute the matrix to make it more nearly triangular * (CWorkspace: none) * (RWorkspace: need N) * IBAL = 1 CALL ZGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: none) * ITAU = 1 IWRK = N + ITAU CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVS ) THEN * * Copy Householder vectors to VS * CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS ) * * Generate unitary matrix in VS * (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) * (RWorkspace: none) * CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) END IF * SDIM = 0 * * Perform QR iteration, accumulating Schur vectors in VS if desired * (CWorkspace: need 1, prefer HSWORK (see comments) ) * (RWorkspace: none) * IWRK = ITAU CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS, $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) IF( IEVAL.GT.0 ) $ INFO = IEVAL * * Sort eigenvalues if desired * IF( WANTST .AND. INFO.EQ.0 ) THEN IF( SCALEA ) $ CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR ) DO 10 I = 1, N BWORK( I ) = SELECT( W( I ) ) 10 CONTINUE * * Reorder eigenvalues and transform Schur vectors * (CWorkspace: none) * (RWorkspace: none) * CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM, $ S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND ) END IF * IF( WANTVS ) THEN * * Undo balancing * (CWorkspace: none) * (RWorkspace: need N) * CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS, $ IERR ) END IF * IF( SCALEA ) THEN * * Undo scaling for the Schur form of A * CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) CALL ZCOPY( N, A, LDA+1, W, 1 ) END IF * WORK( 1 ) = MAXWRK RETURN * * End of ZGEES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgegs.f000066400000000000000000000402331522610125300260730ustar00rootroot00000000000000*> \brief ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine ZGGES. *> *> ZGEGS computes the eigenvalues, Schur form, and, optionally, the *> 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 *> (GNEP). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors (returned in VSL). *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors (returned in VSR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, N) *> On entry, the matrix A. *> On exit, the upper triangular matrix S from the generalized *> Schur factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB, N) *> On entry, the matrix B. *> On exit, the upper triangular matrix T from the generalized *> Schur factorization. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX*16 array, dimension (N) *> The complex scalars alpha that define the eigenvalues of *> GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur *> form of A. *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX*16 array, dimension (N) *> The non-negative real scalars beta that define the *> eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element *> of the triangular factor T. *> *> 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. *> Since either lambda or mu may overflow, they should not, *> in general, be computed. *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is COMPLEX*16 array, dimension (LDVSL,N) *> If JOBVSL = 'V', the matrix of left Schur vectors Q. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >= 1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is COMPLEX*16 array, dimension (LDVSR,N) *> If JOBVSR = 'V', the matrix of right Schur vectors Z. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. LWORK >= max(1,2*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute: *> NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR; *> the optimal LWORK is N*(NB+1). *> *> 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 (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> =1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHA(j) and BETA(j) should be correct for *> j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from ZGGBAL *> =N+2: error return from ZGEQRF *> =N+3: error return from ZUNMQR *> =N+4: error return from ZUNGQR *> =N+5: error return from ZGGHRD *> =N+6: error return from ZHGEQZ (other than failed *> iteration) *> =N+7: error return from ZGGBAK (computing VSL) *> =N+8: error return from ZGGBAK (computing VSR) *> =N+9: error return from ZLASCL (various places) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEeigen * * ===================================================================== SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, $ VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, $ 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 JOBVSL, JOBVSR INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), $ WORK( * ) * .. * * ===================================================================== * * .. 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 ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, $ IRIGHT, IROWS, IRWORK, ITAU, IWORK, LOPT, $ LWKMIN, LWKOPT, NB, NB1, NB2, NB3 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SAFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ, $ ZLACPY, ZLASCL, ZLASET, ZUNGQR, ZUNMQR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * * Test the input arguments * LWKMIN = MAX( 2*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -11 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -13 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -15 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'ZGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'ZUNMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'ZUNGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = N*( NB+1 ) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEGS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) SAFMIN = DLAMCH( 'S' ) SMLNUM = N*SAFMIN / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) THEN CALL ZLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) THEN CALL ZLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * ILEFT = 1 IRIGHT = N + 1 IRWORK = IRIGHT + N IWORK = 1 CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), RWORK( IRWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 10 END IF * * Reduce B to triangular form, and initialize VSL and/or VSR * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWORK IWORK = ITAU + IROWS CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 10 END IF * CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 10 END IF * IF( ILVSL ) THEN CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 10 END IF END IF * IF( ILVSR ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL ZGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 10 END IF * * Perform QZ algorithm, computing Schur vectors if desired * IWORK = ITAU CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWORK ), $ LWORK+1-IWORK, RWORK( IRWORK ), IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 10 END IF * * Apply permutation to VSL and VSR * IF( ILVSL ) THEN CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSL, LDVSL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 10 END IF END IF IF( ILVSR ) THEN CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 10 END IF END IF * * Undo scaling * IF( ILASCL ) THEN CALL ZLASCL( 'U', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL ZLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * IF( ILBSCL ) THEN CALL ZLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL ZLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * 10 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of ZGEGS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgehd2.f000066400000000000000000000146731522610125300261500ustar00rootroot00000000000000*> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEHD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H *> by a unitary similarity transformation: Q**H * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to ZGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= max(1,N). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the n by n general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 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 complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * ALPHA = A( I+1, I ) CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i)**H to A(i+1:ihi,i+1:n) from the left * CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = ALPHA 10 CONTINUE * RETURN * * End of ZGEHD2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgehrd.f000066400000000000000000000252551522610125300262460ustar00rootroot00000000000000*> \brief \b ZGEHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by *> an unitary similarity transformation: Q**H * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that A is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to ZGEBAL; otherwise they should be *> set to 1 and N respectively. See Further Details. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, 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] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to *> zero. *> \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 >= max(1,N). *> 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 *> 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 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of (ihi-ilo) elementary *> reflectors *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> *> 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on *> exit in A(i+2:ihi,i), and tau in TAU(i). *> *> The contents of A are illustrated by the following example, with *> n = 7, ilo = 2 and ihi = 6: *> *> on entry, on exit, *> *> ( a a a a a a a ) ( a a h h h h a ) *> ( a a a a a a ) ( a h h h h a ) *> ( a a a a a a ) ( h h h h h h ) *> ( a a a a a a ) ( v2 h h h h h ) *> ( a a a a a a ) ( v2 v3 h h h h ) *> ( a a a a a a ) ( v2 v3 v4 h h h ) *> ( a ) ( a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This file is a slight modification of LAPACK-3.0's DGEHRD *> subroutine incorporating improvements proposed by Quintana-Orti and *> Van de Geijn (2006). (See DLAHR2.) *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX COMPLEX*16 EI * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB + TSIZE WORK( 1 ) = LWKOPT ENDIF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEHRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code * IF( LWORK.LT.N*NB+TSIZE ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN NB = (LWORK-TSIZE) / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * IWT = 1 + N*NB DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V**H * which performs the reduction, and also the matrix Y = A*V*T * CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), $ WORK( IWT ), LDT, WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE 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 ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the * right * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', I, IB-1, $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) DO 30 J = 0, IB-2 CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, $ A( 1, I+J+1 ), 1 ) 30 CONTINUE * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, $ WORK( IWT ), LDT, A( I+1, I+IB ), LDA, $ WORK, LDWORK ) 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = LWKOPT * RETURN * * End of ZGEHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgelq2.f000066400000000000000000000122041522610125300261550ustar00rootroot00000000000000*> \brief \b ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGELQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGELQ2 computes an LQ factorization of a complex m by n matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in *> A(i,i+1:n), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) ALPHA = A( I, I ) CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * A( I, I ) = ONE CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), $ A( I+1, I ), LDA, WORK ) END IF A( I, I ) = ALPHA CALL ZLACGV( N-I+1, A( I, I ), LDA ) 10 CONTINUE RETURN * * End of ZGELQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgelqf.f000066400000000000000000000166131522610125300262510ustar00rootroot00000000000000*> \brief \b ZGELQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGELQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGELQF computes an LQ factorization of a complex M-by-N matrix A: *> 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 >= 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \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. LWORK >= max(1,M). *> For optimum performance LWORK >= M*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 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in *> A(i,i+1:n), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGELQF( M, N, A, LDA, TAU, 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, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL ZLARFB( 'Right', 'No transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of ZGELQF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgelqt.f000066400000000000000000000133011522610125300262560ustar00rootroot00000000000000*> \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 June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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/MB), where each *> block is of order MB except for the last block, which is of order *> IB = K - (B-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-K 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgelqt3.f000066400000000000000000000163601522610125300263510ustar00rootroot00000000000000*> \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 November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th row *> above 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.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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, 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgemlqt.f000066400000000000000000000175171522610125300264500ustar00rootroot00000000000000*> \brief \b ZGEMLQT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEMLQT + 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 *> *> ZGEMLQT 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 orthogonal matrix defined as the product of K *> elementary reflectors: *> *> Q = H(1) H(2) . . . H(K) = I - V T V**H *> *> 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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,M) if SIDE = 'L', *> (LDV,N) if SIDE = 'R' *> 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. LDV >= max(1,K). *> \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-K 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**H C, C Q**H 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 November 2017 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. 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 * .. * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgemqr.f000066400000000000000000000172161522610125300262660ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgemqrt.f000066400000000000000000000175501522610125300264530ustar00rootroot00000000000000*> \brief \b ZGEMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * COMPLEX*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEMQRT overwrites the general complex 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 orthogonal matrix defined as the product of K *> elementary reflectors: *> *> Q = H(1) H(2) . . . H(K) = I - V T V**H *> *> 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CGEQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension (LDV,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRT in the first K columns 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 CGEQRT, stored as a NB-by-N matrix. *> \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, Q**H C, C Q**H 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*NB if SIDE = 'L', or M*NB 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 complex16GEcomputational * * ===================================================================== SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, 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, NB, 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 ) Q = M ELSE IF ( RIGHT ) THEN LDWORK = MAX( 1, M ) Q = N 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 .OR. K.GT.Q ) THEN INFO = -5 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * 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, $ 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * 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, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * ELSE IF( RIGHT .AND. TRAN ) THEN * 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, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * END IF * RETURN * * End of ZGEMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqp3.f000066400000000000000000000244141522610125300261700ustar00rootroot00000000000000*> \brief \b ZGEQP3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEQP3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGEQP3 computes a QR factorization with column pivoting of a *> matrix A: A*P = Q*R using Level 3 BLAS. *> \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 upper triangle of the array contains the *> min(M,N)-by-N upper trapezoidal matrix R; the elements below *> the diagonal, together with the array TAU, represent the *> unitary matrix Q as a product of min(M,N) elementary *> reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(J).ne.0, the J-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(J)=0, *> the J-th column of A is a free column. *> On exit, if JPVT(J)=K, then the J-th column of A*P was the *> the K-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \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. LWORK >= N+1. *> For optimal 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] RWORK *> \verbatim *> RWORK is DOUBLE PRECISION array, dimension (2*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 complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**H *> *> where tau is a complex scalar, and v is a real/complex vector *> with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in *> A(i+1:m,i), and tau in TAU(i). *> \endverbatim * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> * ===================================================================== SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ 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, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQRF, ZLAQP2, ZLAQPS, ZSWAP, ZUNMQR * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DZNRM2 EXTERNAL ILAENV, DZNRM2 * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test input arguments * ==================== * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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 END IF * IF( INFO.EQ.0 ) THEN MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN IWS = 1 LWKOPT = 1 ELSE IWS = N + 1 NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, -1, -1 ) LWKOPT = ( N + 1 )*NB END IF WORK( 1 ) = DCMPLX( LWKOPT ) * IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQP3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Move initial columns up front. * NFXD = 1 DO 10 J = 1, N IF( JPVT( J ).NE.0 ) THEN IF( J.NE.NFXD ) THEN CALL ZSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) JPVT( J ) = JPVT( NFXD ) JPVT( NFXD ) = J ELSE JPVT( J ) = J END IF NFXD = NFXD + 1 ELSE JPVT( J ) = J END IF 10 CONTINUE NFXD = NFXD - 1 * * Factorize fixed columns * ======================= * * Compute the QR factorization of fixed columns and update * remaining columns. * IF( NFXD.GT.0 ) THEN NA = MIN( M, NFXD ) *CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL ZGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) IF( NA.LT.N ) THEN *CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, *CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, *CC $ INFO ) CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A, $ LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK, $ INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) END IF END IF * * Factorize free columns * ====================== * IF( NFXD.LT.MINMN ) THEN * SM = M - NFXD SN = N - NFXD SMINMN = MINMN - NFXD * * Determine the block size. * NB = ILAENV( INB, 'ZGEQRF', ' ', SM, SN, -1, -1 ) NBMIN = 2 NX = 0 * IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( IXOVER, 'ZGEQRF', ' ', SM, SN, -1, $ -1 ) ) * * IF( NX.LT.SMINMN ) THEN * * Determine if workspace is large enough for blocked code. * MINWS = ( SN+1 )*NB IWS = MAX( IWS, MINWS ) IF( LWORK.LT.MINWS ) THEN * * Not enough workspace to use optimal NB: Reduce NB and * determine the minimum value of NB. * NB = LWORK / ( SN+1 ) NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQRF', ' ', SM, SN, $ -1, -1 ) ) * * END IF END IF END IF * * Initialize partial column norms. The first N elements of work * store the exact column norms. * DO 20 J = NFXD + 1, N RWORK( J ) = DZNRM2( SM, A( NFXD+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) 20 CONTINUE * IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. $ ( NX.LT.SMINMN ) ) THEN * * Use blocked code initially. * J = NFXD + 1 * * Compute factorization: while loop. * * TOPBMN = MINMN - NX 30 CONTINUE IF( J.LE.TOPBMN ) THEN JB = MIN( NB, TOPBMN-J+1 ) * * Factorize JB columns among columns J:N. * CALL ZLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, $ JPVT( J ), TAU( J ), RWORK( J ), $ RWORK( N+J ), WORK( 1 ), WORK( JB+1 ), $ N-J+1 ) * J = J + FJB GO TO 30 END IF ELSE J = NFXD + 1 END IF * * Use unblocked code to factor the last or only block. * * IF( J.LE.MINMN ) $ CALL ZLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), $ TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) ) * END IF * WORK( 1 ) = DCMPLX( LWKOPT ) RETURN * * End of ZGEQP3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqpf.f000066400000000000000000000215351522610125300262540ustar00rootroot00000000000000*> \brief \b ZGEQPF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEQPF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine ZGEQP3. *> *> ZGEQPF computes a QR factorization with column pivoting of a *> complex M-by-N matrix A: A*P = 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. 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 upper triangle of the array contains the *> min(M,N)-by-N upper triangular matrix R; the elements *> below the diagonal, together with the array TAU, *> represent the unitary matrix Q as a product of *> min(m,n) elementary reflectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (N) *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is DOUBLE PRECISION array, dimension (2*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 complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(n) *> *> Each H(i) has the form *> *> H = I - tau * v * v**H *> *> where tau is a complex scalar, and v is a complex vector with *> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). *> *> The matrix P is represented in jpvt as follows: If *> jpvt(j) = i *> then the jth column of P is the ith canonical unit vector. *> *> Partial column norm updating strategy modified by *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. *> -- April 2011 -- *> For more details see LAPACK Working Note 176. *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, 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 * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AII * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQR2, ZLARF, ZLARFG, ZSWAP, ZUNM2R * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, DCONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQPF', -INFO ) RETURN END IF * MN = MIN( M, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL ZSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL ZGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL ZUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A, $ LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n elements of * work store the exact column norms. * DO 20 I = ITEMP + 1, N RWORK( I ) = DZNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) RWORK( N+I ) = RWORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + IDAMAX( N-I+1, RWORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP RWORK( PVT ) = RWORK( I ) RWORK( N+PVT ) = RWORK( N+I ) END IF * * Generate elementary reflector H(i) * AII = A( I, I ) CALL ZLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) A( I, I ) = AII * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = DCMPLX( ONE ) CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN * * 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( M-I.GT.0 ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) ELSE RWORK( J ) = ZERO RWORK( N+J ) = ZERO END IF ELSE RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of ZGEQPF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqr.f000066400000000000000000000225201522610125300261030ustar00rootroot00000000000000* * 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqr2.f000066400000000000000000000120501522610125300261620ustar00rootroot00000000000000*> \brief \b ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGEQR2 computes a QR factorization of a complex m by n matrix A: *> 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. 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, *> 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 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 complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1) H(2) . . . H(k), where k = min(m,n). *> *> 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), *> and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)**H to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of ZGEQR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqrt.f000066400000000000000000000137401522610125300262730ustar00rootroot00000000000000*> \brief \b ZGEQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGEQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGEQRT computes a blocked QR 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] NB *> \verbatim *> NB is INTEGER *> The block size to be used in the blocked QR. MIN(M,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 min(M,N)-by-N upper trapezoidal matrix R (R is *> upper triangular if M >= N); the elements below the diagonal *> are the columns 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 >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (NB*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 June 2017 * *> \ingroup complex16GEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, IINFO, K LOGICAL USE_RECURSIVE_QR PARAMETER( USE_RECURSIVE_QR=.TRUE. ) * .. * .. External Subroutines .. EXTERNAL ZGEQRT2, ZGEQRT3, 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( NB.LT.1 .OR. ( NB.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.NB ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRT', -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, 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 CALL ZGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) ELSE CALL ZGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) END IF IF( I+IB.LE.N ) THEN * * 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+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN * * End of ZGEQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqrt2.f000066400000000000000000000141741522610125300263570ustar00rootroot00000000000000*> \brief \b ZGEQRT2 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/ * *> \htmlonly *> Download ZGEQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> \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 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. *> \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 complex16GEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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**H *> *> where V**H is the conjugate transpose of V. *> \endverbatim *> * ===================================================================== SUBROUTINE ZGEQRT2( 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, LDT, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER( ONE = (1.0D+00,0.0D+00), ZERO = (0.0D+00,0.0D+00) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 AII, ALPHA * .. * .. External Subroutines .. EXTERNAL ZLARFG, ZGEMV, ZGERC, ZTRMV, 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRT2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO I = 1, K * * Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) * CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ T( I, 1 ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(I:M,I+1:N) from the left * AII = A( I, I ) A( I, I ) = ONE * * 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, $ 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, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF END DO * DO I = 2, N AII = A( I, I ) A( I, I ) = ONE * * 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, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL ZTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO * * End of ZGEQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgeqrt3.f000066400000000000000000000162731522610125300263620ustar00rootroot00000000000000*> \brief \b ZGEQRT3 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/ * *> \htmlonly *> Download ZGEQRT3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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. *> *> 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 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. *> \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 June 2016 * *> \ingroup complex16GEcomputational * *> \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 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 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**H *> *> where V**H is the conjugate transpose of V. *> *> For details of the algorithm, see Elmroth and Gustavson (cited above). *> \endverbatim *> * ===================================================================== RECURSIVE SUBROUTINE ZGEQRT3( 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..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = (1.0D+00,0.0D+00) ) * .. * .. Local Scalars .. INTEGER I, I1, J, J1, N1, N2, IINFO * .. * .. External Subroutines .. EXTERNAL ZLARFG, ZTRMM, ZGEMM, XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N .LT. 0 ) THEN INFO = -2 ELSE IF( M .LT. N ) THEN INFO = -1 ELSE IF( LDA .LT. MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT .LT. MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRT3', -INFO ) RETURN END IF * IF( N.EQ.1 ) THEN * * Compute Householder transform when N=1 * CALL ZLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) * ELSE * * Otherwise, split A into blocks... * N1 = N/2 N2 = N-N1 J1 = MIN( N1+1, N ) I1 = MIN( N+1, M ) * * Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H * CALL ZGEQRT3( M, N1, A, LDA, T, LDT, IINFO ) * * Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] * DO J=1,N2 DO I=1,N1 T( I, J+N1 ) = A( I, J+N1 ) END DO END DO 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, & A( J1, J1 ), LDA, ONE, T( 1, J1 ), LDT) * 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, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL ZTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * DO J=1,N2 DO I=1,N1 A( I, J+N1 ) = A( I, J+N1 ) - T( I, J+N1 ) END DO END DO * * 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, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 * DO I=1,N1 DO J=1,N2 T( I, J+N1 ) = CONJG(A( J+N1, I )) END DO END DO * 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, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), 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, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] * [ 0 R2 ] [ 0 T2] * END IF * RETURN * * End of ZGEQRT3 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgerq2.f000066400000000000000000000123341522610125300261670ustar00rootroot00000000000000*> \brief \b ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGERQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZGERQ2 computes an RQ factorization of a complex m by n matrix A: *> A = R * 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,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the m by n matrix A. *> On exit, if m <= n, the upper triangle of the subarray *> A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; *> if m >= n, the elements on and above the (m-n)-th subdiagonal *> contain the m by n upper trapezoidal matrix R; the remaining *> elements, 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,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of elementary reflectors *> *> Q = H(1)**H H(2)**H . . . H(k)**H, where k = min(m,n). *> *> 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on *> exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, 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, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. 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( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGERQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = K, 1, -1 * * Generate elementary reflector H(i) to annihilate * A(m-k+i,1:n-k+i-1) * CALL ZLACGV( N-K+I, A( M-K+I, 1 ), LDA ) ALPHA = A( M-K+I, N-K+I ) CALL ZLARFG( N-K+I, ALPHA, A( M-K+I, 1 ), LDA, TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * A( M-K+I, N-K+I ) = ONE CALL ZLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, $ TAU( I ), A, LDA, WORK ) A( M-K+I, N-K+I ) = ALPHA CALL ZLACGV( N-K+I-1, A( M-K+I, 1 ), LDA ) 10 CONTINUE RETURN * * End of ZGERQ2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgesc2.f000066400000000000000000000126341522610125300261550ustar00rootroot00000000000000*> \brief \b ZGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGESC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * .. Scalar Arguments .. * INTEGER LDA, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * COMPLEX*16 A( LDA, * ), RHS( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGESC2 solves a system of linear equations *> *> A * X = scale* RHS *> *> with a general N-by-N matrix A using the LU factorization with *> complete pivoting computed by ZGETC2. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix A computed by ZGETC2: A = P * L * U * Q *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is COMPLEX*16 array, dimension N. *> On entry, the right hand side vector b. *> On exit, the solution vector X. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, SCALE contains the scale factor. SCALE is chosen *> 0 <= SCALE <= 1 to prevent owerflow in the solution. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) COMPLEX*16 A( LDA, * ), RHS( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION BIGNUM, EPS, SMLNUM COMPLEX*16 TEMP * .. * .. External Subroutines .. EXTERNAL ZLASWP, ZSCAL * .. * .. External Functions .. INTEGER IZAMAX DOUBLE PRECISION DLAMCH EXTERNAL IZAMAX, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX * .. * .. Executable Statements .. * * Set constant to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Apply permutations IPIV to RHS * CALL ZLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) * * Solve for L part * DO 20 I = 1, N - 1 DO 10 J = I + 1, N RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) 10 CONTINUE 20 CONTINUE * * Solve for U part * SCALE = ONE * * Check for scaling * I = IZAMAX( N, RHS, 1 ) IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN TEMP = DCMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) ) CALL ZSCAL( N, TEMP, RHS( 1 ), 1 ) SCALE = SCALE*DBLE( TEMP ) END IF DO 40 I = N, 1, -1 TEMP = DCMPLX( ONE, ZERO ) / A( I, I ) RHS( I ) = RHS( I )*TEMP DO 30 J = I + 1, N RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) 30 CONTINUE 40 CONTINUE * * Apply permutations JPIV to the solution (RHS) * CALL ZLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) RETURN * * End of ZGESC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgetc2.f000066400000000000000000000143241522610125300261540ustar00rootroot00000000000000*> \brief \b ZGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGETC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGETC2 computes an LU factorization, using complete pivoting, of the *> n-by-n matrix A. The factorization has the form A = P * L * U * Q, *> where P and Q are permutation matrices, L is lower triangular with *> unit diagonal elements and U is upper triangular. *> *> This is a level 1 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \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 n-by-n matrix to be factored. *> On exit, the factors L and U from the factorization *> A = P*L*U*Q; the unit diagonal elements of L are not stored. *> If U(k, k) appears to be less than SMIN, U(k, k) is given the *> value of SMIN, giving a nonsingular perturbed system. *> \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). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = k, U(k, k) is likely to produce overflow if *> one tries to solve for x in Ax = b. So U is perturbed *> to avoid the overflow. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complex16GEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IP, IPV, J, JP, JPV DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX * .. * .. External Subroutines .. EXTERNAL ZGERU, ZSWAP * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Handle the case N=1 by itself * IF( N.EQ.1 ) THEN IPIV( 1 ) = 1 JPIV( 1 ) = 1 IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN INFO = 1 A( 1, 1 ) = DCMPLX( SMLNUM, ZERO ) END IF RETURN END IF * * Factorize A using complete pivoting. * Set pivots less than SMIN to SMIN * DO 40 I = 1, N - 1 * * Find max element in matrix A * XMAX = ZERO DO 20 IP = I, N DO 10 JP = I, N IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( A( IP, JP ) ) IPV = IP JPV = JP END IF 10 CONTINUE 20 CONTINUE IF( I.EQ.1 ) $ SMIN = MAX( EPS*XMAX, SMLNUM ) * * Swap rows * IF( IPV.NE.I ) $ CALL ZSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) IPIV( I ) = IPV * * Swap columns * IF( JPV.NE.I ) $ CALL ZSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) JPIV( I ) = JPV * * Check for singularity * IF( ABS( A( I, I ) ).LT.SMIN ) THEN INFO = I A( I, I ) = DCMPLX( SMIN, ZERO ) END IF DO 30 J = I + 1, N A( J, I ) = A( J, I ) / A( I, I ) 30 CONTINUE CALL ZGERU( N-I, N-I, -DCMPLX( ONE ), A( I+1, I ), 1, $ A( I, I+1 ), LDA, A( I+1, I+1 ), LDA ) 40 CONTINUE * IF( ABS( A( N, N ) ).LT.SMIN ) THEN INFO = N A( N, N ) = DCMPLX( SMIN, ZERO ) END IF * * Set last pivots to N * IPIV( N ) = N JPIV( N ) = N * RETURN * * End of ZGETC2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zggbak.f000066400000000000000000000203261522610125300262220ustar00rootroot00000000000000*> \brief \b ZGGBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGGBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION LSCALE( * ), RSCALE( * ) * COMPLEX*16 V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGGBAK forms the right or left eigenvectors of a complex generalized *> eigenvalue problem A*x = lambda*B*x, by backward transformation on *> the computed eigenvectors of the balanced pair of matrices output by *> ZGGBAL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the type of backward transformation required: *> = 'N': do nothing, return immediately; *> = 'P': do backward transformation for permutation only; *> = 'S': do backward transformation for scaling only; *> = 'B': do backward transformations for both permutation and *> scaling. *> JOB must be the same as the argument JOB supplied to ZGGBAL. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by ZGGBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the left side of A and B, as returned by ZGGBAL. *> \endverbatim *> *> \param[in] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and/or scaling factors applied *> to the right side of A and B, as returned by ZGGBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is COMPLEX*16 array, dimension (LDV,M) *> On entry, the matrix of right or left eigenvectors to be *> transformed, as returned by ZTGEVC. *> On exit, V is overwritten by the transformed eigenvectors. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the matrix V. LDV >= 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 complex16GBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. Ward, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, 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 JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ) COMPLEX*16 V( LDV, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX, INT * .. * .. Executable Statements .. * * Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN INFO = -4 ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) $ THEN INFO = -5 ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward transformation on right eigenvectors * IF( RIGHTV ) THEN DO 10 I = ILO, IHI CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) 10 CONTINUE END IF * * Backward transformation on left eigenvectors * IF( LEFTV ) THEN DO 20 I = ILO, IHI CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) 20 CONTINUE END IF END IF * * Backward permutation * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward permutation on right eigenvectors * IF( RIGHTV ) THEN IF( ILO.EQ.1 ) $ GO TO 50 DO 40 I = ILO - 1, 1, -1 K = INT(RSCALE( I )) IF( K.EQ.I ) $ GO TO 40 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE * 50 CONTINUE IF( IHI.EQ.N ) $ GO TO 70 DO 60 I = IHI + 1, N K = INT(RSCALE( I )) IF( K.EQ.I ) $ GO TO 60 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 60 CONTINUE END IF * * Backward permutation on left eigenvectors * 70 CONTINUE IF( LEFTV ) THEN IF( ILO.EQ.1 ) $ GO TO 90 DO 80 I = ILO - 1, 1, -1 K = INT(LSCALE( I )) IF( K.EQ.I ) $ GO TO 80 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 80 CONTINUE * 90 CONTINUE IF( IHI.EQ.N ) $ GO TO 110 DO 100 I = IHI + 1, N K = INT(LSCALE( I )) IF( K.EQ.I ) $ GO TO 100 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 100 CONTINUE END IF END IF * 110 CONTINUE * RETURN * * End of ZGGBAK * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zggbal.f000066400000000000000000000374331522610125300262320ustar00rootroot00000000000000*> \brief \b ZGGBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGGBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGGBAL balances a pair of general complex matrices (A,B). This *> involves, first, permuting A and B by similarity transformations to *> isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N *> elements on the diagonal; and second, applying a diagonal similarity *> transformation to rows and columns ILO to IHI to make the rows *> and columns as close in norm as possible. Both steps are optional. *> *> Balancing may reduce the 1-norm of the matrices, and improve the *> accuracy of the computed eigenvalues and/or eigenvectors in the *> generalized eigenvalue problem A*x = lambda*B*x. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies the operations to be performed on A and B: *> = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 *> and RSCALE(I) = 1.0 for i=1,...,N; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> \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 input matrix A. *> On exit, A is overwritten by the balanced matrix. *> If JOB = 'N', A 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,out] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB,N) *> On entry, the input matrix B. *> On exit, B is overwritten by the balanced matrix. *> If JOB = 'N', B is not referenced. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are set to integers such that on exit *> A(i,j) = 0 and B(i,j) = 0 if i > j and *> j = 1,...,ILO-1 or i = IHI+1,...,N. *> If JOB = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> to the left side of A and B. If P(j) is the index of the *> row interchanged with row j, and D(j) is the scaling factor *> applied to row j, then *> LSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> to the right side of A and B. If P(j) is the index of the *> column interchanged with column j, and D(j) is the scaling *> factor applied to column j, then *> RSCALE(j) = P(j) for J = 1,...,ILO-1 *> = D(j) for J = ILO,...,IHI *> = P(j) for J = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> 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 *> *> \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 June 2016 * *> \ingroup complex16GBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. WARD, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, 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..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION THREE, SCLFAC PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, $ M, NR, NRP2 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IZAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * IF( N.EQ.1 ) THEN ILO = 1 IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N DO 10 I = 1, N LSCALE( I ) = ONE RSCALE( I ) = ONE 10 CONTINUE RETURN END IF * K = 1 L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * GO TO 30 * * Permute the matrices A and B to isolate the eigenvalues. * * Find row with one nonzero in columns 1 through L * 20 CONTINUE L = LM1 IF( L.NE.1 ) $ GO TO 30 * RSCALE( 1 ) = 1 LSCALE( 1 ) = 1 GO TO 190 * 30 CONTINUE LM1 = L - 1 DO 80 I = L, 1, -1 DO 40 J = 1, LM1 JP1 = J + 1 IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 50 40 CONTINUE J = L GO TO 70 * 50 CONTINUE DO 60 J = JP1, L IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 80 60 CONTINUE J = JP1 - 1 * 70 CONTINUE M = L IFLOW = 1 GO TO 160 80 CONTINUE GO TO 100 * * Find column with one nonzero in rows K through N * 90 CONTINUE K = K + 1 * 100 CONTINUE DO 150 J = K, L DO 110 I = K, LM1 IP1 = I + 1 IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 120 110 CONTINUE I = L GO TO 140 120 CONTINUE DO 130 I = IP1, L IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 150 130 CONTINUE I = IP1 - 1 140 CONTINUE M = K IFLOW = 2 GO TO 160 150 CONTINUE GO TO 190 * * Permute rows M and I * 160 CONTINUE LSCALE( M ) = I IF( I.EQ.M ) $ GO TO 170 CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) * * Permute columns M and J * 170 CONTINUE RSCALE( M ) = J IF( J.EQ.M ) $ GO TO 180 CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) * 180 CONTINUE GO TO ( 20, 90 )IFLOW * 190 CONTINUE ILO = K IHI = L * IF( LSAME( JOB, 'P' ) ) THEN DO 195 I = ILO, IHI LSCALE( I ) = ONE RSCALE( I ) = ONE 195 CONTINUE RETURN END IF * IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 DO 200 I = ILO, IHI RSCALE( I ) = ZERO LSCALE( I ) = ZERO * WORK( I ) = ZERO WORK( I+N ) = ZERO WORK( I+2*N ) = ZERO WORK( I+3*N ) = ZERO WORK( I+4*N ) = ZERO WORK( I+5*N ) = ZERO 200 CONTINUE * * Compute right side vector in resulting linear equations * BASL = LOG10( SCLFAC ) DO 240 I = ILO, IHI DO 230 J = ILO, IHI IF( A( I, J ).EQ.CZERO ) THEN TA = ZERO GO TO 210 END IF TA = LOG10( CABS1( A( I, J ) ) ) / BASL * 210 CONTINUE IF( B( I, J ).EQ.CZERO ) THEN TB = ZERO GO TO 220 END IF TB = LOG10( CABS1( B( I, J ) ) ) / BASL * 220 CONTINUE WORK( I+4*N ) = WORK( I+4*N ) - TA - TB WORK( J+5*N ) = WORK( J+5*N ) - TA - TB 230 CONTINUE 240 CONTINUE * COEF = ONE / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO IT = 1 * * Start generalized conjugate gradient iteration * 250 CONTINUE * GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) * EW = ZERO EWC = ZERO DO 260 I = ILO, IHI EW = EW + WORK( I+4*N ) EWC = EWC + WORK( I+5*N ) 260 CONTINUE * GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC-THREE*EW ) TC = COEF5*( EW-THREE*EWC ) * CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) * CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) * DO 270 I = ILO, IHI WORK( I ) = WORK( I ) + TC WORK( I+N ) = WORK( I+N ) + T 270 CONTINUE * * Apply matrix to vector * DO 300 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 290 J = ILO, IHI IF( A( I, J ).EQ.CZERO ) $ GO TO 280 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 280 CONTINUE IF( B( I, J ).EQ.CZERO ) $ GO TO 290 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 290 CONTINUE WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM 300 CONTINUE * DO 330 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 320 I = ILO, IHI IF( A( I, J ).EQ.CZERO ) $ GO TO 310 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 310 CONTINUE IF( B( I, J ).EQ.CZERO ) $ GO TO 320 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 320 CONTINUE WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM 330 CONTINUE * SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) ALPHA = GAMMA / SUM * * Determine correction to current iteration * CMAX = ZERO DO 340 I = ILO, IHI COR = ALPHA*WORK( I+N ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR COR = ALPHA*WORK( I ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( I ) = RSCALE( I ) + COR 340 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 350 * CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) * PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 250 * * End generalized conjugate gradient iteration * 350 CONTINUE SFMIN = DLAMCH( 'S' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) DO 360 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = INT(LSCALE( I ) + SIGN( HALF, LSCALE( I ) )) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR ICAB = IZAMAX( IHI, A( 1, I ), 1 ) CAB = ABS( A( ICAB, I ) ) ICAB = IZAMAX( IHI, B( 1, I ), 1 ) CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) JC = INT(RSCALE( I ) + SIGN( HALF, RSCALE( I ) )) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( I ) = SCLFAC**JC 360 CONTINUE * * Row scaling of matrices A and B * DO 370 I = ILO, IHI CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) 370 CONTINUE * * Column scaling of matrices A and B * DO 380 J = ILO, IHI CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) 380 CONTINUE * RETURN * * End of ZGGBAL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgges.f000066400000000000000000000454751522610125300261100ustar00rootroot00000000000000*> \brief ZGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGGES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGGES computes for a pair of N-by-N complex nonsymmetric matrices *> (A,B), the generalized eigenvalues, the generalized complex Schur *> form (S, T), and optionally left and/or right Schur vectors (VSL *> and VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) *> *> where (VSR)**H is the conjugate-transpose of VSR. *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> triangular matrix S and the upper triangular matrix T. The leading *> columns of VSL and VSR then form an unitary basis for the *> corresponding left and right eigenspaces (deflating subspaces). *> *> (If only the generalized eigenvalues are needed, use the driver *> ZGGEV instead, which is faster.) *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0, and even for both being zero. *> *> A pair of matrices (S,T) is in generalized complex Schur form if S *> and T are upper triangular and, in addition, the diagonal elements *> of T are non-negative real numbers. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG). *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of two COMPLEX*16 arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue ALPHA(j)/BETA(j) is selected if *> SELCTG(ALPHA(j),BETA(j)) is true. *> *> Note that a selected complex eigenvalue may no longer satisfy *> SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since *> ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned), in this *> case INFO is set to N+2 (See INFO below). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX*16 array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX*16 array, dimension (N) *> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the *> generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), *> j=1,...,N are the diagonals of the complex Schur form (A,B) *> output by ZGGES. The BETA(j) will be non-negative real. *> *> Note: the quotients ALPHA(j)/BETA(j) may easily over- or *> underflow, and BETA(j) may even be zero. Thus, the user *> should avoid naively computing the ratio alpha/beta. *> However, ALPHA will be always less than and usually *> comparable with norm(A) in magnitude, and BETA always less *> than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is COMPLEX*16 array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >= 1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is COMPLEX*16 array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. LWORK >= max(1,2*N). *> For good performance, LWORK must generally be larger. *> *> 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 (8*N) *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> =1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHA(j) and BETA(j) should be correct for *> j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in ZHGEQZ *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in ZTGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEeigen * * ===================================================================== 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.7.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 JOBVSL, JOBVSR, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), $ WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. 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 CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN, $ LWKOPT DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, $ PVSR, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, $ ZUNMQR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -14 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -16 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed 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.) * IF( INFO.EQ.0 ) THEN LWKMIN = MAX( 1, 2*N ) LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) ) LWKOPT = MAX( LWKOPT, N + $ N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, -1 ) ) IF( ILVSL ) THEN LWKOPT = MAX( LWKOPT, N + $ N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) ) END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) $ INFO = -18 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * (Real Workspace: need 6*N) * ILEFT = 1 IRIGHT = N + 1 IRWRK = IRIGHT + N CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Complex Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = 1 IWRK = ITAU + IROWS CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Complex Workspace: need N, prefer N*NB) * CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * (Complex Workspace: need N, prefer N*NB) * IF( ILVSL ) THEN CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * CALL ZGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IERR ) * SDIM = 0 * * Perform QZ algorithm, computing Schur vectors if desired * (Complex Workspace: need N) * (Real Workspace: need N) * IWRK = ITAU CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ), $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 30 END IF * * Sort eigenvalues ALPHA/BETA if desired * (Workspace: none needed) * IF( WANTST ) THEN * * Undo scaling on eigenvalues before selecting * IF( ILASCL ) $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR ) IF( ILBSCL ) $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) ) 10 CONTINUE * CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA, $ BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR, $ DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR ) IF( IERR.EQ.1 ) $ INFO = N + 3 * END IF * * Apply back-permutation to VSL and VSR * (Workspace: none needed) * IF( ILVSL ) $ CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSL, LDVSL, IERR ) IF( ILVSR ) $ CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VSR, LDVSR, IERR ) * * Undo scaling * IF( ILASCL ) THEN CALL ZLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) END IF * IF( ILBSCL ) THEN CALL ZLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. SDIM = 0 DO 20 I = 1, N CURSL = SELCTG( ALPHA( I ), BETA( I ) ) IF( CURSL ) $ SDIM = SDIM + 1 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 LASTSL = CURSL 20 CONTINUE * END IF * 30 CONTINUE * WORK( 1 ) = LWKOPT * RETURN * * End of ZGGES * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zgghrd.f000066400000000000000000000252001522610125300262360ustar00rootroot00000000000000*> \brief \b ZGGHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZGGHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper *> Hessenberg form using unitary transformations, where A is a *> general matrix and B is upper triangular. The form of the *> generalized eigenvalue problem is *> A*x = lambda*B*x, *> and B is typically made upper triangular by computing its QR *> factorization and moving the unitary matrix Q to the left side *> of the equation. *> *> This subroutine simultaneously reduces A to a Hessenberg matrix H: *> Q**H*A*Z = H *> and transforms B to another upper triangular matrix T: *> Q**H*B*Z = T *> in order to reduce the problem to its standard form *> H*y = lambda*T*y *> where y = Z**H*x. *> *> The unitary matrices Q and Z are determined as products of Givens *> rotations. They may either be formed explicitly, or they may be *> postmultiplied into input matrices Q1 and Z1, so that *> Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H *> Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H *> If Q1 is the unitary matrix from the QR factorization of B in the *> original equation A*x = lambda*B*x, then ZGGHRD reduces the original *> problem to generalized Hessenberg form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': do not compute Q; *> = 'I': Q is initialized to the unit matrix, and the *> unitary matrix Q is returned; *> = 'V': Q must contain a unitary matrix Q1 on entry, *> and the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': do not compute Z; *> = 'I': Z is initialized to the unit matrix, and the *> unitary matrix Z is returned; *> = 'V': Z must contain a unitary matrix Z1 on entry, *> and the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI mark the rows and columns of A which are to be *> reduced. It is assumed that A is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are *> normally set by a previous call to ZGGBAL; otherwise they *> should be set to 1 and N respectively. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, N) *> On entry, the N-by-N general matrix to be reduced. *> On exit, the upper triangle and the first subdiagonal of A *> are overwritten with the upper Hessenberg matrix H, and the *> rest is set to zero. *> \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 N-by-N upper triangular matrix B. *> On exit, the upper triangular matrix T = Q**H B Z. The *> elements below the diagonal are set to zero. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the unitary matrix Q1, typically *> from the QR factorization of B. *> On exit, if COMPQ='I', the unitary matrix Q, and if *> COMPQ = 'V', the product Q1*Q. *> Not referenced if COMPQ='N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the unitary matrix Z1. *> On exit, if COMPZ='I', the unitary matrix Z, and if *> COMPZ = 'V', the product Z1*Z. *> Not referenced if COMPZ='N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. *> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. *> \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 *> *> This routine reduces A to Hessenberg and B to triangular form by *> an unblocked reduction, as described in _Matrix_Computations_, *> by Golub and van Loan (Johns Hopkins Press). *> \endverbatim *> * ===================================================================== SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, 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 COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ILQ, ILZ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW DOUBLE PRECISION C COMPLEX*16 CTEMP, S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Decode COMPQ * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * * Decode COMPZ * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Test the input parameters. * INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGHRD', -INFO ) RETURN END IF * * Initialize Q and Z if desired. * IF( ICOMPQ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Zero out lower triangle of B * DO 20 JCOL = 1, N - 1 DO 10 JROW = JCOL + 1, N B( JROW, JCOL ) = CZERO 10 CONTINUE 20 CONTINUE * * Reduce A and B * DO 40 JCOL = ILO, IHI - 2 * DO 30 JROW = IHI, JCOL + 2, -1 * * Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) * CTEMP = A( JROW-1, JCOL ) CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = CZERO CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, C, S ) CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, $ B( JROW, JROW-1 ), LDB, C, S ) IF( ILQ ) $ CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, $ DCONJG( S ) ) * * Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) * CTEMP = B( JROW, JROW ) CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S, $ B( JROW, JROW ) ) B( JROW, JROW-1 ) = CZERO CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, $ S ) IF( ILZ ) $ CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) 30 CONTINUE 40 CONTINUE * RETURN * * End of ZGGHRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zhgeqz.f000066400000000000000000000675051522610125300262770ustar00rootroot00000000000000*> \brief \b ZHGEQZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZHGEQZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * .. * .. Array Arguments .. * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ), * $ Q( LDQ, * ), T( LDT, * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T), *> where H is an upper Hessenberg matrix and T is upper triangular, *> 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. *> If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced *> 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 *> eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) *> A*x = lambda*B*x *> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the *> alternate form of the GNEP *> mu*A*y = B*y. *> The values of alpha and beta for the i-th eigenvalue can be read *> directly from the generalized Schur form: alpha = S(i,i), *> beta = P(i,i). *> *> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix *> Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), *> pp. 241--256. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; *> = 'S': Computer eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'N': Left Schur vectors (Q) are not computed; *> = 'I': Q is initialized to the unit matrix and the matrix Q *> of left Schur vectors of (H,T) is returned; *> = 'V': Q must contain a unitary matrix Q1 on entry and *> the product Q1*Q is returned. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Right Schur vectors (Z) are not computed; *> = 'I': Q is initialized to the unit matrix and the matrix Z *> of right Schur vectors of (H,T) is returned; *> = 'V': Z must contain a unitary matrix Z1 on entry and *> the product Z1*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices H, T, Q, and Z. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI mark the rows and columns of H which are in *> Hessenberg form. It is assumed that A is already upper *> triangular in rows and columns 1:ILO-1 and IHI+1:N. *> If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH, N) *> On entry, the N-by-N upper Hessenberg matrix H. *> On exit, if JOB = 'S', H contains the upper triangular *> matrix S from the generalized Schur factorization. *> If JOB = 'E', the diagonal of H matches that of S, but *> the rest of H is unspecified. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max( 1, N ). *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT, N) *> On entry, the N-by-N upper triangular matrix T. *> On exit, if JOB = 'S', T contains the upper triangular *> matrix P from the generalized Schur factorization. *> If JOB = 'E', the diagonal of T matches that of P, but *> the rest of T is unspecified. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max( 1, N ). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX*16 array, dimension (N) *> The complex scalars alpha that define the eigenvalues of *> GNEP. ALPHA(i) = S(i,i) in the generalized Schur *> factorization. *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX*16 array, dimension (N) *> The real non-negative scalars beta that define the *> eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized *> Schur factorization. *> *> 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. *> Since either lambda or mu may overflow, they should not, *> in general, be computed. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the unitary matrix Q1 used in the *> reduction of (A,B) to generalized Hessenberg form. *> 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 COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If COMPQ='V' or 'I', then LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the unitary matrix Z1 used in the *> reduction of (A,B) to generalized Hessenberg form. *> On exit, if COMPZ = 'I', the unitary matrix of right Schur *> vectors of (H,T), and if COMPZ = 'V', the unitary matrix of *> right Schur vectors of (A,B). *> Not referenced if COMPZ = 'N'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If COMPZ='V' or 'I', then LDZ >= 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 dimension of the array WORK. LWORK >= max(1,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] RWORK *> \verbatim *> RWORK is DOUBLE PRECISION 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 *> = 1,...,N: the QZ iteration did not converge. (H,T) is not *> in Schur form, but ALPHA(i) and BETA(i), *> i=INFO+1,...,N should be correct. *> = N+1,...,2*N: the shift calculation failed. (H,T) is not *> in Schur form, but ALPHA(i) and BETA(i), *> i=INFO-N+1,...,N should be correct. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We assume that complex ABS works as long as its value is less than *> overflow. *> \endverbatim *> * ===================================================================== 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.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 COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ), $ Q( LDQ, * ), T( LDT, * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. 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 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D+0 ) * .. * .. Local Scalars .. LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ U12, X * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANHS EXTERNAL LSAME, DLAMCH, ZLANHS * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN, $ SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) * .. * .. Executable Statements .. * * Decode JOB, COMPQ, COMPZ * IF( LSAME( JOB, 'E' ) ) THEN ILSCHR = .FALSE. ISCHUR = 1 ELSE IF( LSAME( JOB, 'S' ) ) THEN ILSCHR = .TRUE. ISCHUR = 2 ELSE ISCHUR = 0 END IF * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Check Argument Values * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.EQ.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 ) THEN INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE IF( LDH.LT.N ) THEN INFO = -8 ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -16 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -18 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHGEQZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * * WORK( 1 ) = CMPLX( 1 ) IF( N.LE.0 ) THEN WORK( 1 ) = DCMPLX( 1 ) RETURN END IF * * Initialize Q and Z * IF( ICOMPQ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * * Machine Constants * IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) BSCALE = ONE / MAX( SAFMIN, BNORM ) * * * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN SIGNBC = DCONJG( T( J, J ) / ABSB ) T( J, J ) = ABSB IF( ILSCHR ) THEN CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 ) CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 ) ELSE CALL ZSCAL( 1, SIGNBC, H( J, J ), 1 ) END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE T( J, J ) = CZERO END IF ALPHA( J ) = H( J, J ) BETA( J ) = T( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps * IF( IHI.LT.ILO ) $ GO TO 190 * * MAIN QZ ITERATION LOOP * * Initialize dynamic indices * * Eigenvalues ILAST+1:N have been found. * Column operations modify rows IFRSTM:whatever * Row operations modify columns whatever:ILASTM * * If only eigenvalues are being computed, then * IFRSTM is the row of the last splitting row above row ILAST; * this is always at least ILO. * IITER counts iterations since the last eigenvalue was found, * to tell when to use an extraordinary shift. * MAXIT is the maximum number of QZ sweeps allowed. * ILAST = IHI IF( ILSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ESHIFT = CZERO MAXIT = 30*( IHI-ILO+1 ) * DO 170 JITER = 1, MAXIT * * Check for too many iterations. * IF( JITER.GT.MAXIT ) $ GO TO 180 * * Split the matrix if possible. * * Two tests: * 1: H(j,j-1)=0 or j=ILO * 2: T(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN H( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN T( ILAST, ILAST ) = CZERO GO TO 50 END IF * * General case: j \brief \b ZHSEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZHSEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZHSEQR computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**H, where T is an upper triangular matrix (the *> Schur form), and Z is the unitary matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': compute eigenvalues only; *> = 'S': compute eigenvalues and the Schur form T. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': no Schur vectors are computed; *> = 'I': Z is initialized to the unit matrix and the matrix Z *> of Schur vectors of H is returned; *> = 'V': Z must contain an unitary matrix Q on entry, and *> the product Q*Z is returned. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally *> set by a previous call to ZGEBAL, and then passed to ZGEHRD *> when the matrix output by ZGEBAL is reduced to Hessenberg *> form. Otherwise ILO and IHI should be set to 1 and N *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and JOB = 'S', H contains the upper *> triangular matrix T from the Schur decomposition (the *> Schur form). If INFO = 0 and JOB = 'E', the contents of *> H are unspecified on exit. (The output value of H when *> INFO.GT.0 is given under the description of INFO below.) *> *> Unlike earlier versions of ZHSEQR, this subroutine may *> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 *> or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX*16 array, dimension (N) *> The computed eigenvalues. If JOB = 'S', the eigenvalues are *> stored in the same order as on the diagonal of the Schur *> form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,N) *> If COMPZ = 'N', Z is not referenced. *> If COMPZ = 'I', on entry Z need not be set and on exit, *> if INFO = 0, Z contains the unitary matrix Z of the Schur *> vectors of H. If COMPZ = 'V', on entry Z must contain an *> N-by-N matrix Q, which is assumed to be equal to the unit *> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, *> if INFO = 0, Z contains Q*Z. *> Normally Q is the unitary matrix generated by ZUNGHR *> after the call to ZGEHRD which formed the Hessenberg matrix *> H. (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if COMPZ = 'I' or *> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient and delivers very good and sometimes *> optimal performance. However, LWORK as large as 11*N *> may be required for optimal performance. A workspace *> query is recommended to determine the optimal workspace *> size. *> *> If LWORK = -1, then ZHSEQR does a workspace query. *> In this case, ZHSEQR checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .LT. 0: if INFO = -i, the i-th argument had an illegal *> value *> .GT. 0: if INFO = i, ZHSEQR failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and JOB = 'E', then on exit, the *> remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and JOB = 'S', then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a unitary matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and COMPZ = 'V', then on exit *> *> (final value of Z) = (initial value of Z)*U *> *> where U is the unitary matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'I', then on exit *> (final value of Z) = U *> where U is the unitary matrix in (*) (regard- *> less of the value of JOB.) *> *> If INFO .GT. 0 and COMPZ = 'N', then Z is not *> accessed. *> \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 Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> Default values supplied by *> ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). *> It is suggested that these defaults be adjusted in order *> to attain best performance in each particular *> computational environment. *> *> ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> ISPEC=13: Recommended deflation window size. *> This depends on ILO, IHI and NS. NS is the *> number of simultaneous shifts returned *> by ILAENV(ISPEC=15). (See ISPEC=15 below.) *> The default for (IHI-ILO+1).LE.500 is NS. *> The default for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> ISPEC=14: Nibble crossover point. (See IPARMQ for *> details.) Default: 14% of deflation window *> size. *> *> ISPEC=15: Number of simultaneous shifts in a multishift *> QR iteration. *> *> If IHI-ILO+1 is ... *> *> greater than ...but less ... the *> or equal to ... than default is *> *> 1 30 NS = 2(+) *> 30 60 NS = 4(+) *> 60 150 NS = 10(+) *> 150 590 NS = ** *> 590 3000 NS = 64 *> 3000 6000 NS = 128 *> 6000 infinity NS = 256 *> *> (+) By default some or all matrices of this order *> are passed to the implicit double shift routine *> ZLAHQR and this parameter is ignored. See *> ISPEC=12 above and comments in IPARMQ for *> details. *> *> (**) The asterisks (**) indicate an ad-hoc *> function of N increasing from 10 to 64. *> *> ISPEC=16: Select structured matrix multiply. *> If the number of simultaneous shifts (specified *> by ISPEC=15) is less than 14, then the default *> for ISPEC=16 is 0. Otherwise the default for *> ISPEC=16 is 2. *> \endverbatim * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. * * ===================================================================== SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ 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 IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is * . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== INTEGER NL PARAMETER ( NL = 49 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0d0 ) * .. * .. Local Arrays .. COMPLEX*16 HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. INTEGER KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. INTEGER ILAENV LOGICAL LSAME EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Executable Statements .. * * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN * * ==== Quick return in case of invalid argument. ==== * CALL XERBLA( 'ZHSEQR', -INFO ) RETURN * ELSE IF( N.EQ.0 ) THEN * * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ELSE IF( LQUERY ) THEN * * ==== Quick return in case of a workspace query ==== * CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, $ LDZ, WORK, LWORK, INFO ) * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, $ N ) ) ), RZERO ) RETURN * ELSE * * ==== copy eigenvalues isolated by ZGEBAL ==== * IF( ILO.GT.1 ) $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) IF( IHI.LT.N ) $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) * * ==== Initialize Z, if requested ==== * IF( INITZ ) $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * * ==== Quick return if possible ==== * IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * * ==== ZLAHQR/ZLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== * IF( N.GT.NMIN ) THEN CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, $ Z, LDZ, WORK, LWORK, INFO ) ELSE * * ==== Small matrix ==== * CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, $ Z, LDZ, INFO ) * IF( INFO.GT.0 ) THEN * * ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds * . when ZLAHQR fails. ==== * KBOT = INFO * IF( N.GE.NL ) THEN * * ==== Larger matrices have enough subdiagonal scratch * . space to call ZLAQR0 directly. ==== * CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ELSE * * ==== Tiny matrices don't have enough subdiagonal * . scratch space to benefit from ZLAQR0. Hence, * . tiny matrices must be copied into a larger * . array before calling ZLAQR0. ==== * CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) HL( N+1, N ) = ZERO CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), $ NL ) CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) IF( WANTT .OR. INFO.NE.0 ) $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) END IF END IF END IF * * ==== Clear out the trash, if necessary. ==== * IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== * WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), $ DBLE( WORK( 1 ) ) ), RZERO ) END IF * * ==== End of ZHSEQR ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlabrd.f000066400000000000000000000357671522610125300262520ustar00rootroot00000000000000*> \brief \b ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLABRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), * $ Y( LDY, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLABRD reduces the first NB rows and columns of a complex general *> m by n matrix A to upper or lower real bidiagonal form by a unitary *> transformation Q**H * A * P, and returns the matrices X and Y which *> are needed to apply the transformation to the unreduced part of A. *> *> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower *> bidiagonal form. *> *> This is an auxiliary routine called by ZGEBRD *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of leading rows and columns of A to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, the first NB rows and columns of the matrix are *> overwritten; the rest of the array is unchanged. *> If m >= n, elements on and below the diagonal in the first NB *> columns, with the array TAUQ, represent the unitary *> matrix Q as a product of elementary reflectors; and *> elements above the diagonal in the first NB rows, with the *> array TAUP, represent the unitary matrix P as a product *> of elementary reflectors. *> If m < n, elements below the diagonal in the first NB *> columns, with the array TAUQ, represent the unitary *> matrix Q as a product of elementary reflectors, and *> elements on and above the diagonal in the first NB rows, *> with the array TAUP, represent the unitary matrix P 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,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (NB) *> The diagonal elements of the first NB rows and columns of *> the reduced matrix. D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (NB) *> The off-diagonal elements of the first NB rows and columns of *> the reduced matrix. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is COMPLEX*16 array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is COMPLEX*16 array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the unitary matrix P. See Further Details. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is COMPLEX*16 array, dimension (LDX,NB) *> The m-by-nb matrix X required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,M). *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is COMPLEX*16 array, dimension (LDY,NB) *> The n-by-nb matrix Y required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H *> *> where tauq and taup are complex scalars, and v and u are complex *> vectors. *> *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in *> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The elements of the vectors v and u together form the m-by-nb matrix *> V and the nb-by-n matrix U**H which are needed, with X and Y, to apply *> the transformation to the unreduced part of the matrix, using a block *> update of the form: A := A - V*Y**H - X*U**H. *> *> The contents of A on exit are illustrated by the following examples *> with nb = 2: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) *> ( v1 v2 a a a ) ( v1 1 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix which is unchanged, *> vi denotes an element of the vector defining H(i), and ui an element *> of the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), $ Y( LDY, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+1:m,i) * ALPHA = A( I, I ) CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = ALPHA IF( I.LT.N ) THEN A( I, I ) = ONE * * Compute Y(i+1:n,i) * CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE, $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ A( I, 1 ), LDA, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ X( I, 1 ), LDX, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL ZLACGV( N-I, A( I, I+1 ), LDA ) CALL ZLACGV( I, A( I, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) CALL ZLACGV( I, A( I, 1 ), LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE, $ A( I, I+1 ), LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) * * Generate reflection P(i) to annihilate A(i,i+2:n) * ALPHA = A( I, I+1 ) CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, $ TAUP( I ) ) E( I ) = ALPHA A( I, I+1 ) = ONE * * Compute X(i+1:m,i) * CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE, $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO, $ X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE, $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ), $ LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) * * Generate reflection P(i) to annihilate A(i,i+1:n) * ALPHA = A( I, I ) CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = ALPHA IF( I.LT.M ) THEN A( I, I ) = ONE * * Compute X(i+1:m,i) * CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE, $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO, $ X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) * * Update A(i+1:m,i) * CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+2:m,i) * ALPHA = A( I+1, I ) CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Compute Y(i+1:n,i) * CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE, $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE, $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE, $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) ELSE CALL ZLACGV( N-I+1, A( I, I ), LDA ) END IF 20 CONTINUE END IF RETURN * * End of ZLABRD * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlacgv.f000066400000000000000000000054441522610125300262470ustar00rootroot00000000000000*> \brief \b ZLACGV conjugates a complex vector. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLACGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACGV( N, X, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLACGV conjugates a complex vector of length N. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The length of the vector X. N >= 0. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX*16 array, dimension *> (1+(N-1)*abs(INCX)) *> On entry, the vector of length N to be conjugated. *> On exit, X is overwritten with conjg(X). *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The spacing between successive elements of X. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACGV( N, X, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IOFF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( INCX.EQ.1 ) THEN DO 10 I = 1, N X( I ) = DCONJG( X( I ) ) 10 CONTINUE ELSE IOFF = 1 IF( INCX.LT.0 ) $ IOFF = 1 - ( N-1 )*INCX DO 20 I = 1, N X( IOFF ) = DCONJG( X( IOFF ) ) IOFF = IOFF + INCX 20 CONTINUE END IF RETURN * * End of ZLACGV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlacn2.f000066400000000000000000000174541522610125300261560ustar00rootroot00000000000000*> \brief \b ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLACN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) * * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST * .. * .. Array Arguments .. * INTEGER ISAVE( 3 ) * COMPLEX*16 V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLACN2 estimates the 1-norm of a square, complex matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX*16 array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX*16 array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**H * X, if KASE=2, *> where A**H is the conjugate transpose of A, and ZLACN2 must be *> re-called with all the other parameters unchanged. *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to ZLACN2, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**H * X. *> On the final return from ZLACN2, KASE will again be 0. *> \endverbatim *> *> \param[in,out] ISAVE *> \verbatim *> ISAVE is INTEGER array, dimension (3) *> ISAVE is used to save variables between calls to ZLACN2 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Originally named CONEST, dated March 16, 1988. *> *> Last modified: April, 1999 *> *> This is a thread safe version of ZLACON, which uses the array ISAVE *> in place of a SAVE statement, as follows: *> *> ZLACON ZLACN2 *> JUMP ISAVE(1) *> J ISAVE(2) *> ITER ISAVE(3) *> \endverbatim * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISAVE( 3 ) COMPLEX*16 V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. INTEGER I, JLAST DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER IZMAX1 DOUBLE PRECISION DLAMCH, DZSUM1 EXTERNAL IZMAX1, DLAMCH, DZSUM1 * .. * .. External Subroutines .. EXTERNAL ZCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = DCMPLX( ONE / DBLE( N ) ) 10 CONTINUE KASE = 1 ISAVE( 1 ) = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) * * ................ ENTRY (ISAVE( 1 ) = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = DZSUM1( N, X, 1 ) * DO 30 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, $ DIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 ISAVE( 1 ) = 2 RETURN * * ................ ENTRY (ISAVE( 1 ) = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE ISAVE( 2 ) = IZMAX1( N, X, 1 ) ISAVE( 3 ) = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( ISAVE( 2 ) ) = CONE KASE = 1 ISAVE( 1 ) = 3 RETURN * * ................ ENTRY (ISAVE( 1 ) = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL ZCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DZSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, $ DIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 ISAVE( 1 ) = 4 RETURN * * ................ ENTRY (ISAVE( 1 ) = 4) * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = ISAVE( 2 ) ISAVE( 2 ) = IZMAX1( N, X, 1 ) IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN ISAVE( 3 ) = ISAVE( 3 ) + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 ISAVE( 1 ) = 5 RETURN * * ................ ENTRY (ISAVE( 1 ) = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL ZCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of ZLACN2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlacon.f000066400000000000000000000163001522610125300262400ustar00rootroot00000000000000*> \brief \b ZLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLACON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACON( N, V, X, EST, KASE ) * * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST * .. * .. Array Arguments .. * COMPLEX*16 V( N ), X( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLACON estimates the 1-norm of a square, complex matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX*16 array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX*16 array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**H * X, if KASE=2, *> where A**H is the conjugate transpose of A, and ZLACON must be *> re-called with all the other parameters unchanged. *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to ZLACON, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**H * X. *> On the final return from ZLACON, KASE will again be 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> Originally named CONEST, dated March 16, 1988. \n *> Last modified: April, 1999 * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE ZLACON( N, V, X, EST, KASE ) * * -- LAPACK auxiliary routine (version 3.7.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 KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. COMPLEX*16 V( N ), X( N ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER IZMAX1 DOUBLE PRECISION DLAMCH, DZSUM1 EXTERNAL IZMAX1, DLAMCH, DZSUM1 * .. * .. External Subroutines .. EXTERNAL ZCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = DCMPLX( ONE / DBLE( N ) ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = DZSUM1( N, X, 1 ) * DO 30 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, $ DIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE J = IZMAX1( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( J ) = CONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL ZCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DZSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, $ DIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = J J = IZMAX1( N, X, 1 ) IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND. $ ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL ZCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of ZLACON * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlacpy.f000066400000000000000000000077541522610125300262710ustar00rootroot00000000000000*> \brief \b ZLACPY copies all or part of one two-dimensional array to another. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLACPY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLACPY copies all or part of a two-dimensional matrix A to another *> matrix B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be copied to B. *> = 'U': Upper triangular part *> = 'L': Lower triangular part *> Otherwise: All of the matrix A *> \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] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> The m by n matrix A. If UPLO = 'U', only the upper trapezium *> is accessed; if UPLO = 'L', only the lower trapezium is *> accessed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB,N) *> On exit, B = A in the locations specified by UPLO. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.7.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, LDB, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE * ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF * RETURN * * End of ZLACPY * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zladiv.f000066400000000000000000000045711522610125300262520ustar00rootroot00000000000000*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLADIV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * COMPLEX*16 FUNCTION ZLADIV( X, Y ) * * .. Scalar Arguments .. * COMPLEX*16 X, Y * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y *> will not overflow on an intermediary step unless the results *> overflows. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is COMPLEX*16 *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is COMPLEX*16 *> The complex scalars X and Y. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== COMPLEX*16 FUNCTION ZLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 3.7.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 .. COMPLEX*16 X, Y * .. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION ZI, ZR * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, $ ZI ) ZLADIV = DCMPLX( ZR, ZI ) * RETURN * * End of ZLADIV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaev2.f000066400000000000000000000106211522610125300261550ustar00rootroot00000000000000*> \brief \b ZLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAEV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix *> [ A B ] *> [ CONJG(B) C ]. *> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the *> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right *> eigenvector for RT1, giving the decomposition *> *> [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ] *> [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is COMPLEX*16 *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX*16 *> The (1,2) element and the conjugate of the (2,1) element of *> the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is COMPLEX*16 *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is DOUBLE PRECISION *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is DOUBLE PRECISION *> The eigenvalue of smaller absolute value. *> \endverbatim *> *> \param[out] CS1 *> \verbatim *> CS1 is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SN1 *> \verbatim *> SN1 is COMPLEX*16 *> The vector (CS1, SN1) is a unit right eigenvector for RT1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> CS1 and SN1 are accurate to a few ulps barring over/underflow. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION CS1, RT1, RT2 COMPLEX*16 A, B, C, SN1 * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION T COMPLEX*16 W * .. * .. External Subroutines .. EXTERNAL DLAEV2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG * .. * .. Executable Statements .. * IF( ABS( B ).EQ.ZERO ) THEN W = ONE ELSE W = DCONJG( B ) / ABS( B ) END IF CALL DLAEV2( DBLE( A ), ABS( B ), DBLE( C ), RT1, RT2, CS1, T ) SN1 = W*T RETURN * * End of ZLAEV2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlahqr.f000066400000000000000000000440641522610125300262630ustar00rootroot00000000000000*> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAHQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAHQR is an auxiliary routine called by CHSEQR to update the *> eigenvalues and Schur decomposition already computed by CHSEQR, by *> dealing with the Hessenberg submatrix in rows and columns ILO to *> IHI. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows and *> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). *> ZLAHQR works primarily with the Hessenberg submatrix in rows *> and columns ILO to IHI, but applies transformations to all of *> H if WANTT is .TRUE.. *> 1 <= ILO <= max(1,IHI); IHI <= N. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO is zero and if WANTT is .TRUE., then H *> is upper triangular in rows and columns ILO:IHI. If INFO *> is zero and if WANTT is .FALSE., then the contents of H *> are unspecified on exit. The output state of H in case *> INF is positive is below under the description of INFO. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX*16 array, dimension (N) *> The computed eigenvalues ILO to IHI are stored in the *> corresponding elements of W. If WANTT is .TRUE., the *> eigenvalues are stored in the same order as on the diagonal *> of the Schur form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,N) *> If WANTZ is .TRUE., on entry Z must contain the current *> matrix Z of transformations accumulated by CHSEQR, and on *> exit Z has been updated; transformations are applied only to *> the submatrix Z(ILOZ:IHIZ,ILO:IHI). *> If WANTZ is .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, ZLAHQR failed to compute all the *> eigenvalues ILO to IHI in a total of 30 iterations *> per eigenvalue; elements i+1:ihi of W contain *> those eigenvalues which have been successfully *> computed. *> *> If INFO .GT. 0 and WANTT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the *> eigenvalues of the upper Hessenberg matrix *> rows and columns ILO thorugh INFO of the final, *> output value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> (*) (initial value of H)*U = U*(final value of H) *> where U is an orthognal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> (final value of Z) = (initial value of Z)*U *> where U is the orthogonal matrix in (*) *> (regardless of the value of WANTT.) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> \verbatim *> *> 02-96 Based on modifications by *> David Day, Sandia National Laboratory, USA *> *> 12-04 Further modifications by *> Ralph Byers, University of Kansas, USA *> This is a modified version of ZLAHQR from LAPACK version 3.0. *> It is (1) more robust against overflow and underflow and *> (2) adopts the more conservative Ahues & Tisseur stopping *> criterion (LAWN 122, 1997). *> \endverbatim *> * ===================================================================== SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * ========================================================= * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE, HALF PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) DOUBLE PRECISION DAT1 PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, $ V2, X, Y DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, $ SAFMIN, SMLNUM, SX, T2, TST, ULP INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M, $ NH, NZ * .. * .. Local Arrays .. COMPLEX*16 V( 2 ) * .. * .. External Functions .. COMPLEX*16 ZLADIV DOUBLE PRECISION DLAMCH EXTERNAL ZLADIV, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * * ==== clear out the trash ==== DO 10 J = ILO, IHI - 3 H( J+2, J ) = ZERO H( J+3, J ) = ZERO 10 CONTINUE IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * ==== ensure that subdiagonal entries are real ==== IF( WANTT ) THEN JLO = 1 JHI = N ELSE JLO = ILO JHI = IHI END IF DO 20 I = ILO + 1, IHI IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN * ==== The following redundant normalization * . avoids problems with both gradual and * . sudden underflow in ABS(H(I,I-1)) ==== SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) SC = DCONJG( SC ) / ABS( SC ) H( I, I-1 ) = ABS( H( I, I-1 ) ) CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), $ H( JLO, I ), 1 ) IF( WANTZ ) $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) END IF 20 CONTINUE * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITMAX is the total number of QR iterations allowed. * 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 * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 30 CONTINUE IF( I.LT.ILO ) $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO DO 130 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * DO 40 K = I, L + 1, -1 IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) $ GO TO 50 TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) IF( TST.EQ.ZERO ) THEN IF( K-2.GE.ILO ) $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) IF( K+1.LE.IHI ) $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) END IF * ==== The following is a conservative small subdiagonal * . deflation criterion due to Ahues & Tisseur (LAWN 122, * . 1997). It has better mathematical foundation and * . improves accuracy in some examples. ==== IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) AA = MAX( CABS1( H( K, K ) ), $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) BB = MIN( CABS1( H( K, K ) ), $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) S = AA + AB IF( BA*( AB / S ).LE.MAX( SMLNUM, $ ULP*( BB*( AA / S ) ) ) )GO TO 50 END IF 40 CONTINUE 50 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 ) THEN * * Exceptional shift. * S = DAT1*ABS( DBLE( H( L+1, L ) ) ) T = S + H( L, L ) ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) T = S + H( I, I ) ELSE * * Wilkinson's shift. * T = H( I, I ) U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) S = CABS1( U ) IF( S.NE.RZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) SX = CABS1( X ) S = MAX( S, CABS1( X ) ) Y = S*SQRT( ( X / S )**2+( U / S )**2 ) IF( SX.GT.RZERO ) THEN IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* $ DIMAG( Y ).LT.RZERO )Y = -Y END IF T = T - U*ZLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 60 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T H21 = DBLE( H( M+1, M ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 H10 = DBLE( H( M, M-1 ) ) IF( ABS( H10 )*ABS( H21 ).LE.ULP* $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) $ GO TO 70 60 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T H21 = DBLE( H( L+1, L ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 70 CONTINUE * * Single-shift QR step * DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. * * V(2) is always real before the call to ZLARFG, and hence * after the call T2 ( = T1*V(2) ) is also real. * IF( K.GT.M ) $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO END IF V2 = V( 2 ) T2 = DBLE( T1*V2 ) * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 80 J = K, I2 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 80 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * DO 90 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) 90 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 100 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) 100 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN * * If the QR step was started at row M > L because two * consecutive small subdiagonals were found, then extra * scaling must be performed to ensure that H(M,M-1) remains * real. * TEMP = ONE - T1 TEMP = TEMP / ABS( TEMP ) H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP DO 110 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) IF( WANTZ ) THEN CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), $ 1 ) END IF END IF 110 CONTINUE END IF 120 CONTINUE * * Ensure that H(I,I-1) is real. * TEMP = H( I, I-1 ) IF( DIMAG( TEMP ).NE.RZERO ) THEN RTEMP = ABS( TEMP ) H( I, I-1 ) = RTEMP TEMP = TEMP / RTEMP IF( I2.GT.I ) $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) IF( WANTZ ) THEN CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) END IF END IF * 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 140 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * * return to start of the main loop with new value of I. * I = L - 1 GO TO 30 * 150 CONTINUE RETURN * * End of ZLAHQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlahr2.f000066400000000000000000000241571522610125300261650ustar00rootroot00000000000000*> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAHR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) *> matrix A so that elements below the k-th subdiagonal are zero. The *> reduction is performed by an unitary similarity transformation *> Q**H * A * Q. The routine returns the matrices V and T which determine *> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. *> *> This is an auxiliary routine called by ZGEHRD. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The offset for the reduction. Elements below the k-th *> subdiagonal in the first NB columns are reduced to zero. *> K < N. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N-K+1) *> On entry, the n-by-(n-k+1) general matrix A. *> On exit, the elements on and above the k-th subdiagonal in *> the first NB columns are overwritten with the corresponding *> elements of the reduced matrix; the elements below the k-th *> subdiagonal, with the array TAU, represent the matrix Q as a *> product of elementary reflectors. The other columns of A are *> unchanged. 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] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (NB) *> The scalar factors of the elementary reflectors. See Further *> Details. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,NB) *> The upper triangular matrix T. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is COMPLEX*16 array, dimension (LDY,NB) *> The n-by-nb matrix Y. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of nb elementary reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in *> A(i+k+1:n,i), and tau in TAU(i). *> *> The elements of the vectors v together form the (n-k+1)-by-nb matrix *> V which is needed, with T and Y, to apply the transformation to the *> unreduced part of the matrix, using an update of the form: *> A := (I - V*T*V**H) * (A - Y*V**H). *> *> The contents of A on exit are illustrated by the following example *> with n = 7, k = 3 and nb = 2: *> *> ( a a a a a ) *> ( a a a a a ) *> ( a a a a a ) *> ( h h a a a ) *> ( v1 h a a a ) *> ( v1 v2 a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix A, h denotes a *> modified element of the upper Hessenberg matrix H, and vi denotes an *> element of the vector defining H(i). *> *> This subroutine is a slight modification of LAPACK-3.0's DLAHRD *> incorporating improvements proposed by Quintana-Orti and Van de *> Gejin. Note that the entries of A(1:K,2:NB) differ from those *> returned by the original LAPACK-3.0's DLAHRD routine. (This *> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) *> \endverbatim * *> \par References: * ================ *> *> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the *> performance of reduction to Hessenberg form," ACM Transactions on *> Mathematical Software, 32(2):180-194, June 2006. *> * ===================================================================== SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.7.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 K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 EI * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(K+1:N,I) * * Update I-th column of A - Y * V**H * 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 ) * * Apply I - V * T**H * V**H to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1**H * b1 * CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) 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, $ 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', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * 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', $ '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 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(I) to annihilate * A(K+I+1:N,I) * CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(K+1:N,I) * 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, $ 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, $ 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 ) * * Compute T(1:I,I) * CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * * Compute Y(1:K,1:NB) * CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) 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, $ 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', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * RETURN * * End of ZLAHR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaic1.f000066400000000000000000000243151522610125300261420ustar00rootroot00000000000000*> \brief \b ZLAIC1 applies one step of incremental condition estimation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAIC1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * .. Scalar Arguments .. * INTEGER J, JOB * DOUBLE PRECISION SEST, SESTPR * COMPLEX*16 C, GAMMA, S * .. * .. Array Arguments .. * COMPLEX*16 W( J ), X( J ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAIC1 applies one step of incremental condition estimation in *> its simplest version: *> *> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j *> lower triangular matrix L, such that *> twonorm(L*x) = sest *> Then ZLAIC1 computes sestpr, s, c such that *> the vector *> [ s*x ] *> xhat = [ c ] *> is an approximate singular vector of *> [ L 0 ] *> Lhat = [ w**H gamma ] *> in the sense that *> twonorm(Lhat*xhat) = sestpr. *> *> Depending on JOB, an estimate for the largest or smallest singular *> value is computed. *> *> Note that [s c]**H and sestpr**2 is an eigenpair of the system *> *> diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] *> [ conjg(gamma) ] *> *> where alpha = x**H * w. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is INTEGER *> = 1: an estimate for the largest singular value is computed. *> = 2: an estimate for the smallest singular value is computed. *> \endverbatim *> *> \param[in] J *> \verbatim *> J is INTEGER *> Length of X and W *> \endverbatim *> *> \param[in] X *> \verbatim *> X is COMPLEX*16 array, dimension (J) *> The j-vector x. *> \endverbatim *> *> \param[in] SEST *> \verbatim *> SEST is DOUBLE PRECISION *> Estimated singular value of j by j matrix L *> \endverbatim *> *> \param[in] W *> \verbatim *> W is COMPLEX*16 array, dimension (J) *> The j-vector w. *> \endverbatim *> *> \param[in] GAMMA *> \verbatim *> GAMMA is COMPLEX*16 *> The diagonal element gamma. *> \endverbatim *> *> \param[out] SESTPR *> \verbatim *> SESTPR is DOUBLE PRECISION *> Estimated singular value of (j+1) by (j+1) matrix Lhat. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is COMPLEX*16 *> Sine needed in forming xhat. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is COMPLEX*16 *> Cosine needed in forming xhat. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * -- LAPACK auxiliary routine (version 3.7.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 J, JOB DOUBLE PRECISION SEST, SESTPR COMPLEX*16 C, GAMMA, S * .. * .. Array Arguments .. COMPLEX*16 W( J ), X( J ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) DOUBLE PRECISION HALF, FOUR PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, B, EPS, NORMA, S1, S2, $ SCL, T, TEST, TMP, ZETA1, ZETA2 COMPLEX*16 ALPHA, COSINE, SINE * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCONJG, MAX, SQRT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH COMPLEX*16 ZDOTC EXTERNAL DLAMCH, ZDOTC * .. * .. Executable Statements .. * EPS = DLAMCH( 'Epsilon' ) ALPHA = ZDOTC( J, X, 1, W, 1 ) * ABSALP = ABS( ALPHA ) ABSGAM = ABS( GAMMA ) ABSEST = ABS( SEST ) * IF( JOB.EQ.1 ) THEN * * Estimating largest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN S1 = MAX( ABSGAM, ABSALP ) IF( S1.EQ.ZERO ) THEN S = ZERO C = ONE SESTPR = ZERO ELSE S = ALPHA / S1 C = GAMMA / S1 TMP = SQRT( S*DCONJG( S )+C*DCONJG( C ) ) S = S / TMP C = C / TMP SESTPR = S1*TMP END IF RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ONE C = ZERO TMP = MAX( ABSEST, ABSALP ) S1 = ABSEST / TMP S2 = ABSALP / TMP SESTPR = TMP*SQRT( S1*S1+S2*S2 ) RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ONE C = ZERO SESTPR = S2 ELSE S = ZERO C = ONE SESTPR = S1 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 SCL = SQRT( ONE+TMP*TMP ) SESTPR = S2*SCL S = ( ALPHA / S2 ) / SCL C = ( GAMMA / S2 ) / SCL ELSE TMP = S2 / S1 SCL = SQRT( ONE+TMP*TMP ) SESTPR = S1*SCL S = ( ALPHA / S1 ) / SCL C = ( GAMMA / S1 ) / SCL END IF RETURN ELSE * * normal case * ZETA1 = ABSALP / ABSEST ZETA2 = ABSGAM / ABSEST * B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF C = ZETA1*ZETA1 IF( B.GT.ZERO ) THEN T = C / ( B+SQRT( B*B+C ) ) ELSE T = SQRT( B*B+C ) - B END IF * SINE = -( ALPHA / ABSEST ) / T COSINE = -( GAMMA / ABSEST ) / ( ONE+T ) TMP = SQRT( SINE*DCONJG( SINE )+COSINE*DCONJG( COSINE ) ) S = SINE / TMP C = COSINE / TMP SESTPR = SQRT( T+ONE )*ABSEST RETURN END IF * ELSE IF( JOB.EQ.2 ) THEN * * Estimating smallest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN SESTPR = ZERO IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN SINE = ONE COSINE = ZERO ELSE SINE = -DCONJG( GAMMA ) COSINE = DCONJG( ALPHA ) END IF S1 = MAX( ABS( SINE ), ABS( COSINE ) ) S = SINE / S1 C = COSINE / S1 TMP = SQRT( S*DCONJG( S )+C*DCONJG( C ) ) S = S / TMP C = C / TMP RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ZERO C = ONE SESTPR = ABSGAM RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ZERO C = ONE SESTPR = S1 ELSE S = ONE C = ZERO SESTPR = S2 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 SCL = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST*( TMP / SCL ) S = -( DCONJG( GAMMA ) / S2 ) / SCL C = ( DCONJG( ALPHA ) / S2 ) / SCL ELSE TMP = S2 / S1 SCL = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST / SCL S = -( DCONJG( GAMMA ) / S1 ) / SCL C = ( DCONJG( ALPHA ) / S1 ) / SCL END IF RETURN ELSE * * normal case * ZETA1 = ABSALP / ABSEST ZETA2 = ABSGAM / ABSEST * NORMA = MAX( ONE+ZETA1*ZETA1+ZETA1*ZETA2, $ ZETA1*ZETA2+ZETA2*ZETA2 ) * * See if root is closer to zero or to ONE * TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) IF( TEST.GE.ZERO ) THEN * * root is close to zero, compute directly * B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF C = ZETA2*ZETA2 T = C / ( B+SQRT( ABS( B*B-C ) ) ) SINE = ( ALPHA / ABSEST ) / ( ONE-T ) COSINE = -( GAMMA / ABSEST ) / T SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST ELSE * * root is closer to ONE, shift by that amount * B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF C = ZETA1*ZETA1 IF( B.GE.ZERO ) THEN T = -C / ( B+SQRT( B*B+C ) ) ELSE T = B - SQRT( B*B+C ) END IF SINE = -( ALPHA / ABSEST ) / T COSINE = -( GAMMA / ABSEST ) / ( ONE+T ) SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST END IF TMP = SQRT( SINE*DCONJG( SINE )+COSINE*DCONJG( COSINE ) ) S = SINE / TMP C = COSINE / TMP RETURN * END IF END IF RETURN * * End of ZLAIC1 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlamtsqr.f000066400000000000000000000270641522610125300266400ustar00rootroot00000000000000*> \brief \b ZLAMTSQR * * 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**H * C C * Q**H *> 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Conjugate Transpose, apply Q**H. *> \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] 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**H*C or C*Q**H 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlanhs.f000066400000000000000000000133021522610125300262500ustar00rootroot00000000000000*> \brief \b ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLANHS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLANHS returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> Hessenberg matrix A. *> \endverbatim *> *> \return ZLANHS *> \verbatim *> *> ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in ZLANHS as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, ZLANHS is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> The n by n upper Hessenberg matrix A; the part of A below the *> first sub-diagonal is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHS = VALUE RETURN * * End of ZLANHS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqp2.f000066400000000000000000000172021522610125300261650ustar00rootroot00000000000000*> \brief \b ZLAQP2 computes a QR factorization with column pivoting of the matrix block. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQP2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) * * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION VN1( * ), VN2( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAQP2 computes a QR factorization with column pivoting of *> the block A(OFFSET+1:M,1:N). *> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted *> but no factorized. OFFSET >= 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 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of A*P (a leading column); if JPVT(i) = 0, *> the i-th column of A is a free column. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is DOUBLE PRECISION array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is DOUBLE PRECISION array, dimension (N) *> The vector with the exact column norms. *> \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 complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 LDA, M, N, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION VN1( * ), VN2( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AII * .. * .. External Subroutines .. EXTERNAL ZLARF, ZLARFG, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. Executable Statements .. * MN = MIN( M-OFFSET, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Compute factorization. * DO 20 I = 1, MN * OFFPI = OFFSET + I * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) * IF( PVT.NE.I ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP VN1( PVT ) = VN1( I ) VN2( PVT ) = VN2( I ) END IF * * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, $ TAU( I ) ) ELSE CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i)**H to A(offset+i:m,i+1:n) from the left. * AII = A( OFFPI, I ) A( OFFPI, I ) = CONE CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, $ DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, $ WORK( 1 ) ) A( OFFPI, I ) = AII END IF * * Update partial column norms. * DO 10 J = I + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( OFFPI.LT.M ) THEN VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) VN2( J ) = VN1( J ) ELSE VN1( J ) = ZERO VN2( J ) = ZERO END IF ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 10 CONTINUE * 20 CONTINUE * RETURN * * End of ZLAQP2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqps.f000066400000000000000000000254461522610125300262770ustar00rootroot00000000000000*> \brief \b ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQPS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION VN1( * ), VN2( * ) * COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAQPS computes a step of QR factorization with column pivoting *> of a complex M-by-N matrix A by using Blas-3. It tries to factorize *> NB columns from A starting from the row OFFSET+1, and updates all *> of the matrix with Blas-3 xGEMM. *> *> In some cases, due to catastrophic cancellations, it cannot *> factorize NB columns. Hence, the actual number of factorized *> columns is returned in KB. *> *> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \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] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of A that have been factorized in *> previous steps. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to factorize. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER *> The number of columns actually factorized. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, block A(OFFSET+1:M,1:KB) is the triangular *> factor obtained and block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. *> The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has *> been updated. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> JPVT(I) = K <==> Column K of the full matrix A has been *> permuted into position I in AP. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (KB) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is DOUBLE PRECISION array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is DOUBLE PRECISION array, dimension (N) *> The vector with the exact column norms. *> \endverbatim *> *> \param[in,out] AUXV *> \verbatim *> AUXV is COMPLEX*16 array, dimension (NB) *> Auxiliar vector. *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is COMPLEX*16 array, dimension (LDF,NB) *> Matrix F**H = L * Y**H * A. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * * -- LAPACK auxiliary routine (version 3.7.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 KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION VN1( * ), VN2( * ) COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CZERO, CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AKK * .. * .. External Subroutines .. EXTERNAL ZGEMM, ZGEMV, ZLARFG, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, NINT, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. Executable Statements .. * LASTRK = MIN( M, N+OFFSET ) LSTICC = 0 K = 0 TOL3Z = SQRT(DLAMCH('Epsilon')) * * Beginning of while loop. * 10 CONTINUE IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN K = K + 1 RK = OFFSET + K * * Determine ith pivot column and swap if necessary * PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) IF( PVT.NE.K ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) CALL ZSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( K ) JPVT( K ) = ITEMP VN1( PVT ) = VN1( K ) VN2( PVT ) = VN2( K ) END IF * * Apply previous Householder reflectors to column K: * A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**H. * IF( K.GT.1 ) THEN DO 20 J = 1, K - 1 F( K, J ) = DCONJG( F( K, J ) ) 20 CONTINUE CALL ZGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ), $ LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 ) DO 30 J = 1, K - 1 F( K, J ) = DCONJG( F( K, J ) ) 30 CONTINUE END IF * * Generate elementary reflector H(k). * IF( RK.LT.M ) THEN CALL ZLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) ELSE CALL ZLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) END IF * AKK = A( RK, K ) A( RK, K ) = CONE * * Compute Kth column of F: * * Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). * IF( K.LT.N ) THEN CALL ZGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ), $ A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO, $ F( K+1, K ), 1 ) END IF * * Padding F(1:K,K) with zeros. * DO 40 J = 1, K F( J, K ) = CZERO 40 CONTINUE * * Incremental updating of F: * F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**H * *A(RK:M,K). * IF( K.GT.1 ) THEN CALL ZGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ), $ A( RK, 1 ), LDA, A( RK, K ), 1, CZERO, $ AUXV( 1 ), 1 ) * CALL ZGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF, $ AUXV( 1 ), 1, CONE, F( 1, K ), 1 ) END IF * * Update the current row of A: * A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**H. * IF( K.LT.N ) THEN CALL ZGEMM( 'No transpose', 'Conjugate transpose', 1, N-K, $ K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF, $ CONE, A( RK, K+1 ), LDA ) END IF * * Update partial column norms. * IF( RK.LT.LASTRK ) THEN DO 50 J = K + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN VN2( J ) = DBLE( LSTICC ) LSTICC = J ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 50 CONTINUE END IF * A( RK, K ) = AKK * * End of while loop. * GO TO 10 END IF KB = K RK = OFFSET + KB * * Apply the block reflector to the rest of the matrix: * A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - * A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**H. * IF( KB.LT.MIN( N, M-OFFSET ) ) THEN CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB, $ KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, $ CONE, A( RK+1, KB+1 ), LDA ) END IF * * Recomputation of difficult columns. * 60 CONTINUE IF( LSTICC.GT.0 ) THEN 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 * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP GO TO 60 END IF * RETURN * * End of ZLAQPS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqr0.f000066400000000000000000000607701522610125300261750ustar00rootroot00000000000000*> \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQR0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAQR0 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**H, where T is an upper triangular matrix (the *> Schur form), and Z is the unitary matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to ZGEBAL, and then passed to ZGEHRD when the *> matrix output by ZGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H *> contains the upper triangular matrix T from the Schur *> decomposition (the Schur form). If INFO = 0 and WANT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX*16 array, dimension (N) *> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored *> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are *> stored in the same order as on the diagonal of the Schur *> form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then ZLAQR0 does a workspace query. *> In this case, ZLAQR0 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, ZLAQR0 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a unitary matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the unitary matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constant WILK1 is used to form the exceptional * . shifts. ==== DOUBLE PRECISION WILK1 PARAMETER ( WILK1 = 0.75d0 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 DOUBLE PRECISION S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. COMPLEX*16 ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use ZLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to ZLAQR3 ==== * CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, $ LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== ZLAHQR/ZLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 70 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 80 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, $ LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if ZLAQR3 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . ZLAQR3 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, KS + 1, -2 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) W( I-1 ) = W( I ) 30 CONTINUE ELSE * * ==== Got NS/2 or fewer shifts? Use ZLAQR4 or * . ZLAHQR on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) IF( NS.GT.NMIN ) THEN CALL ZLAQR4( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, $ ZDUM, 1, WORK, LWORK, INF ) ELSE CALL ZLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, $ ZDUM, 1, INF ) END IF KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. Scale to avoid * . overflows, underflows and subnormals. * . (The scale factor S can not be zero, * . because H(KBOT,KBOT-1) is nonzero.) ==== * IF( KS.GE.KBOT ) THEN S = CABS1( H( KBOT-1, KBOT-1 ) ) + $ CABS1( H( KBOT, KBOT-1 ) ) + $ CABS1( H( KBOT-1, KBOT ) ) + $ CABS1( H( KBOT, KBOT ) ) AA = H( KBOT-1, KBOT-1 ) / S CC = H( KBOT, KBOT-1 ) / S BB = H( KBOT-1, KBOT ) / S DD = H( KBOT, KBOT ) / S TR2 = ( AA+DD ) / TWO DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC RTDISC = SQRT( -DET ) W( KBOT-1 ) = ( TR2+RTDISC )*S W( KBOT ) = ( TR2-RTDISC )*S * KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) $ THEN SORTED = .false. SWAP = W( I ) W( I ) = W( I+1 ) W( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF END IF * * ==== If there are only two shifts, then use * . only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN W( KBOT-1 ) = W( KBOT ) ELSE W( KBOT ) = W( KBOT-1 ) END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, $ NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 70 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 80 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR0 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqr1.f000066400000000000000000000113651522610125300261720ustar00rootroot00000000000000*> \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQR1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) * * .. Scalar Arguments .. * COMPLEX*16 S1, S2 * INTEGER LDH, N * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), V( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a *> scalar multiple of the first column of the product *> *> (*) K = (H - s1*I)*(H - s2*I) *> *> scaling to avoid overflows and most underflows. *> *> This is useful for starting double implicit shift bulges *> in the QR algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is integer *> Order of the matrix H. N must be either 2 or 3. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is COMPLEX*16 array of dimension (LDH,N) *> The 2-by-2 or 3-by-3 matrix H in (*). *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> The leading dimension of H as declared in *> the calling procedure. LDH.GE.N *> \endverbatim *> *> \param[in] S1 *> \verbatim *> S1 is COMPLEX*16 *> \endverbatim *> *> \param[in] S2 *> \verbatim *> S2 is COMPLEX*16 *> *> S1 and S2 are the shifts defining K in (*) above. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX*16 array of dimension N *> A scalar multiple of the first column of the *> matrix K in (*). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) * * -- LAPACK auxiliary routine (version 3.7.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 .. COMPLEX*16 S1, S2 INTEGER LDH, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), V( * ) * .. * * ================================================================ * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 CDUM, H21S, H31S DOUBLE PRECISION S * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. IF( N.EQ.2 ) THEN S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) IF( S.EQ.RZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO ELSE H21S = H( 2, 1 ) / S V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* $ ( ( H( 1, 1 )-S2 ) / S ) V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) END IF ELSE S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + $ CABS1( H( 3, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO V( 3 ) = ZERO ELSE H21S = H( 2, 1 ) / S H31S = H( 3, 1 ) / S V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) END IF END IF END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqr2.f000066400000000000000000000423051522610125300261710ustar00rootroot00000000000000*> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAQR2 is identical to ZLAQR3 except that it avoids *> recursion by calling ZLAHQR instead of ZLAQR4. *> *> Aggressive early deflation: *> *> ZLAQR2 accepts as input an upper Hessenberg matrix *> H and performs an unitary similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an unitary similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the unitary matrix Z is updated so *> so that the unitary Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the unitary matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by a unitary *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SH *> \verbatim *> SH is COMPLEX*16 array, dimension KBOT *> On output, approximate eigenvalues that may *> be used for shifts are stored in SH(KBOT-ND-NS+1) *> through SR(KBOT-ND). Converged eigenvalues are *> stored in SH(KBOT-ND+1) through SH(KBOT). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX*16 array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is COMPLEX*16 array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension LWORK. *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; ZLAQR2 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.7.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 IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 BETA, CDUM, S, TAU DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to ZGEHRD ==== * CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZUNMHR ==== * CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = JW + MAX( LWK1, LWK2 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SH( KWTOP ) = H( KWTOP, KWTOP ) NS = 1 ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, INFQR ) * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 DO 10 KNT = INFQR + 1, JW * * ==== Small spike tip deflation test ==== * FOO = CABS1( T( NS, NS ) ) IF( FOO.EQ.RZERO ) $ FOO = CABS1( S ) IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) $ THEN * * ==== One more converged eigenvalue ==== * NS = NS - 1 ELSE * * ==== One undeflatable eigenvalue. Move it up out of the * . way. (ZTREXC can not fail in this case.) ==== * IFST = NS CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) ILST = ILST + 1 END IF 10 CONTINUE * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting the diagonal of T improves accuracy for * . graded matrices. ==== * DO 30 I = INFQR + 1, NS IFST = I DO 20 J = I + 1, NS IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) $ IFST = J 20 CONTINUE ILST = I IF( IFST.NE.ILST ) $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 30 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * DO 40 I = INFQR + 1, JW SH( KWTOP+I-1 ) = T( I, I ) 40 CONTINUE * * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL ZCOPY( NS, V, LDV, WORK, 1 ) DO 50 I = 1, NS WORK( I ) = DCONJG( WORK( I ) ) 50 CONTINUE BETA = WORK( 1 ) CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 60 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 70 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 70 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 80 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR2 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqr3.f000066400000000000000000000431541522610125300261750ustar00rootroot00000000000000*> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQR3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Aggressive early deflation: *> *> ZLAQR3 accepts as input an upper Hessenberg matrix *> H and performs an unitary similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an unitary similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the unitary matrix Z is updated so *> so that the unitary Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the unitary matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by a unitary *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is integer *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is integer *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SH *> \verbatim *> SH is COMPLEX*16 array, dimension KBOT *> On output, approximate eigenvalues that may *> be used for shifts are stored in SH(KBOT-ND-NS+1) *> through SR(KBOT-ND). Converged eigenvalues are *> stored in SH(KBOT-ND+1) through SH(KBOT). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX*16 array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is integer *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is COMPLEX*16 array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension LWORK. *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is integer *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; ZLAQR3 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 BETA, CDUM, S, TAU DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, $ LWKOPT, NMIN * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER ILAENV EXTERNAL DLAMCH, ILAENV * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to ZGEHRD ==== * CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZUNMHR ==== * CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZLAQR4 ==== * CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, $ LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SH( KWTOP ) = H( KWTOP, KWTOP ) NS = 1 ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, WORK, LWORK, INFQR ) ELSE CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, INFQR ) END IF * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 DO 10 KNT = INFQR + 1, JW * * ==== Small spike tip deflation test ==== * FOO = CABS1( T( NS, NS ) ) IF( FOO.EQ.RZERO ) $ FOO = CABS1( S ) IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) $ THEN * * ==== One more converged eigenvalue ==== * NS = NS - 1 ELSE * * ==== One undeflatable eigenvalue. Move it up out of the * . way. (ZTREXC can not fail in this case.) ==== * IFST = NS CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) ILST = ILST + 1 END IF 10 CONTINUE * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting the diagonal of T improves accuracy for * . graded matrices. ==== * DO 30 I = INFQR + 1, NS IFST = I DO 20 J = I + 1, NS IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) $ IFST = J 20 CONTINUE ILST = I IF( IFST.NE.ILST ) $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 30 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * DO 40 I = INFQR + 1, JW SH( KWTOP+I-1 ) = T( I, I ) 40 CONTINUE * * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL ZCOPY( NS, V, LDV, WORK, 1 ) DO 50 I = 1, NS WORK( I ) = DCONJG( WORK( I ) ) 50 CONTINUE BETA = WORK( 1 ) CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 60 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 70 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 70 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 80 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR3 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqr4.f000066400000000000000000000610261522610125300261740ustar00rootroot00000000000000*> \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQR4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAQR4 implements one level of recursion for ZLAQR0. *> It is a complete implementation of the small bulge multi-shift *> QR algorithm. It may be called by ZLAQR0 and, for large enough *> deflation window size, it may be called by ZLAQR3. This *> subroutine is identical to ZLAQR0 except that it calls ZLAQR2 *> instead of ZLAQR3. *> *> ZLAQR4 computes the eigenvalues of a Hessenberg matrix H *> and, optionally, the matrices T and Z from the Schur decomposition *> H = Z T Z**H, where T is an upper triangular matrix (the *> Schur form), and Z is the unitary matrix of Schur vectors. *> *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H *> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a *> previous call to ZGEBAL, and then passed to ZGEHRD when the *> matrix output by ZGEBAL is reduced to Hessenberg form. *> Otherwise, ILO and IHI should be set to 1 and N, *> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. *> If N = 0, then ILO = 1 and IHI = 0. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., then H *> contains the upper triangular matrix T from the Schur *> decomposition (the Schur form). If INFO = 0 and WANT is *> .FALSE., then the contents of H are unspecified on exit. *> (The output value of H when INFO.GT.0 is given under the *> description of INFO below.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX*16 array, dimension (N) *> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored *> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are *> stored in the same order as on the diagonal of the Schur *> form returned in H, with W(i) = H(i,i). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient, but LWORK typically as large as 6*N may *> be required for optimal performance. A workspace query *> to determine the optimal workspace size is recommended. *> *> If LWORK = -1, then ZLAQR4 does a workspace query. *> In this case, ZLAQR4 checks the input parameters and *> estimates the optimal workspace size for the given *> values of N, ILO and IHI. The estimate is returned *> in WORK(1). No error message related to LWORK is *> issued by XERBLA. Neither H nor Z are accessed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, ZLAQR4 failed to compute all of *> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR *> and WI contain those eigenvalues which have been *> successfully computed. (Failures are rare.) *> *> If INFO .GT. 0 and WANT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the eigen- *> values of the upper Hessenberg matrix rows and *> columns ILO through INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a unitary matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the unitary matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> \n *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part II: Aggressive Early Deflation, SIAM Journal *> of Matrix Analysis, volume 23, pages 948--973, 2002. *> * ===================================================================== SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constant WILK1 is used to form the exceptional * . shifts. ==== DOUBLE PRECISION WILK1 PARAMETER ( WILK1 = 0.75d0 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 DOUBLE PRECISION S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. COMPLEX*16 ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use ZLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to ZLAQR2 ==== * CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, $ LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== ZLAHQR/ZLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 70 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 80 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, $ LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if ZLAQR2 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . ZLAQR2 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, KS + 1, -2 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) W( I-1 ) = W( I ) 30 CONTINUE ELSE * * ==== Got NS/2 or fewer shifts? Use ZLAHQR * . on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) CALL ZLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, $ 1, INF ) KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. Scale to avoid * . overflows, underflows and subnormals. * . (The scale factor S can not be zero, * . because H(KBOT,KBOT-1) is nonzero.) ==== * IF( KS.GE.KBOT ) THEN S = CABS1( H( KBOT-1, KBOT-1 ) ) + $ CABS1( H( KBOT, KBOT-1 ) ) + $ CABS1( H( KBOT-1, KBOT ) ) + $ CABS1( H( KBOT, KBOT ) ) AA = H( KBOT-1, KBOT-1 ) / S CC = H( KBOT, KBOT-1 ) / S BB = H( KBOT-1, KBOT ) / S DD = H( KBOT, KBOT ) / S TR2 = ( AA+DD ) / TWO DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC RTDISC = SQRT( -DET ) W( KBOT-1 ) = ( TR2+RTDISC )*S W( KBOT ) = ( TR2-RTDISC )*S * KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) $ THEN SORTED = .false. SWAP = W( I ) W( I ) = W( I+1 ) W( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF END IF * * ==== If there are only two shifts, then use * . only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN W( KBOT-1 ) = W( KBOT ) ELSE W( KBOT ) = W( KBOT-1 ) END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, $ NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 70 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 80 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR4 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaqr5.f000066400000000000000000001016321522610125300261730ustar00rootroot00000000000000*> \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLAQR5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), * $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLAQR5, called by ZLAQR0, performs a *> single small-bulge multi-shift QR sweep. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is logical scalar *> WANTT = .true. if the triangular Schur factor *> is being computed. WANTT is set to .false. otherwise. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is logical scalar *> WANTZ = .true. if the unitary Schur factor is being *> computed. WANTZ is set to .false. otherwise. *> \endverbatim *> *> \param[in] KACC22 *> \verbatim *> KACC22 is integer with value 0, 1, or 2. *> Specifies the computation mode of far-from-diagonal *> orthogonal updates. *> = 0: ZLAQR5 does not accumulate reflections and does not *> use matrix-matrix multiply to update far-from-diagonal *> matrix entries. *> = 1: ZLAQR5 accumulates reflections and uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries. *> = 2: ZLAQR5 accumulates reflections, uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries, *> and takes advantage of 2-by-2 block structure during *> matrix multiplies. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is integer scalar *> N is the order of the Hessenberg matrix H upon which this *> subroutine operates. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is integer scalar *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is integer scalar *> These are the first and last rows and columns of an *> isolated diagonal block upon which the QR sweep is to be *> applied. It is assumed without a check that *> either KTOP = 1 or H(KTOP,KTOP-1) = 0 *> and *> either KBOT = N or H(KBOT+1,KBOT) = 0. *> \endverbatim *> *> \param[in] NSHFTS *> \verbatim *> NSHFTS is integer scalar *> NSHFTS gives the number of simultaneous shifts. NSHFTS *> must be positive and even. *> \endverbatim *> *> \param[in,out] S *> \verbatim *> S is COMPLEX*16 array of size (NSHFTS) *> S contains the shifts of origin that define the multi- *> shift QR sweep. On output S may be reordered. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is COMPLEX*16 array of size (LDH,N) *> On input H contains a Hessenberg matrix. On output a *> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied *> to the isolated diagonal block in rows and columns KTOP *> through KBOT. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is integer scalar *> LDH is the leading dimension of H just as declared in the *> calling procedure. LDH.GE.MAX(1,N). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> 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,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is integer scalar *> LDA is the leading dimension of Z just as declared in *> the calling procedure. LDZ.GE.N. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is COMPLEX*16 array of size (LDV,NSHFTS/2) *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is integer scalar *> LDV is the leading dimension of V as declared in the *> calling procedure. LDV.GE.3. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is COMPLEX*16 array of size *> (LDU,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is integer scalar *> LDU is the leading dimension of U just as declared in the *> in the calling subroutine. LDU.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is integer scalar *> NH is the number of columns in array WH available for *> workspace. NH.GE.1. *> \endverbatim *> *> \param[out] WH *> \verbatim *> WH is COMPLEX*16 array of size (LDWH,NH) *> \endverbatim *> *> \param[in] LDWH *> \verbatim *> LDWH is integer scalar *> Leading dimension of WH just as declared in the *> calling procedure. LDWH.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is integer scalar *> NV is the number of rows in WV agailable for workspace. *> NV.GE.1. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is COMPLEX*16 array of size *> (LDWV,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is integer scalar *> LDWV is the leading dimension of WV as declared in the *> in the calling subroutine. LDWV.GE.NV. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par References: * ================ *> *> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR *> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 *> Performance, SIAM Journal of Matrix Analysis, volume 23, pages *> 929--947, 2002. *> * ===================================================================== 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.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 .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 ALPHA, BETA, CDUM, REFSUM DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, $ SMLNUM, TST1, TST2, ULP INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, $ NS, NU LOGICAL ACCUM, BLK22, BMP22 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. * INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD * .. * .. Local Arrays .. COMPLEX*16 VT( 3 ) * .. * .. External Subroutines .. EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, $ ZTRMM * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== If there are no shifts, then there is nothing to do. ==== * IF( NSHFTS.LT.2 ) $ RETURN * * ==== If the active block is empty or 1-by-1, then there * . is nothing to do. ==== * IF( KTOP.GE.KBOT ) $ RETURN * * ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) * * ==== Machine constants for deflation ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Use accumulated reflections to update far-from-diagonal * . entries ? ==== * ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) * * ==== If so, exploit the 2-by-2 block structure? ==== * BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) * * ==== clear trash ==== * IF( KTOP+2.LE.KBOT ) $ H( KTOP+2, KTOP ) = ZERO * * ==== NBMPS = number of 2-shift bulges in the chain ==== * NBMPS = NS / 2 * * ==== KDU = width of slab ==== * KDU = 6*NBMPS - 3 * * ==== Create and chase chains of NBMPS bulges ==== * DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 NDCOL = INCOL + KDU IF( ACCUM ) $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) * * ==== Near-the-diagonal bulge chase. The following loop * . performs the near-the-diagonal part of a small bulge * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal * . chunk extends from column INCOL to column NDCOL * . (including both column INCOL and column NDCOL). The * . following loop chases a 3*NBMPS column long chain of * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL * . may be less than KTOP and and NDCOL may be greater than * . KBOT indicating phantom columns from which to chase * . bulges before they are actually introduced or to which * . to chase bulges beyond column KBOT.) ==== * DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) * * ==== Bulges number MTOP to MBOT are active double implicit * . shift bulges. There may or may not also be small * . 2-by-2 bulge, if there is room. The inactive bulges * . (if any) must wait until the active bulges have moved * . down the diagonal to make room. The phantom matrix * . paradigm described above helps keep track. ==== * MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) M22 = MBOT + 1 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. $ ( KBOT-2 ) * * ==== Generate reflections to chase the chain right * . one column. (The minimum value of K is KTOP-1.) ==== * DO 10 M = MTOP, MBOT K = KRCOL + 3*( M-1 ) IF( K.EQ.KTOP-1 ) THEN CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), $ S( 2*M ), V( 1, M ) ) ALPHA = V( 1, M ) CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) ELSE BETA = H( K+1, K ) V( 2, M ) = H( K+2, K ) V( 3, M ) = H( K+3, K ) CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant * . deflation or destructive underflow. In the * . underflow case, try the two-small-subdiagonals * . trick to try to reinflate the bulge. ==== * IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Atypical case: collapsed. Attempt to * . reintroduce ignoring H(K+1,K) and H(K+2,K). * . If the fill resulting from the new * . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), $ S( 2*M ), VT ) ALPHA = VT( 1 ) CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = DCONJG( VT( 1 ) )* $ ( H( K+1, K )+DCONJG( VT( 2 ) )* $ H( K+2, K ) ) * IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* $ ( CABS1( H( K, K ) )+CABS1( H( K+1, $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would * . create non-negligible fill. Use * . the old one with trepidation. ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would * . create only negligible fill. * . Replace the old reflector with * . the new one. ==== * H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) V( 2, M ) = VT( 2 ) V( 3, M ) = VT( 3 ) END IF END IF END IF 10 CONTINUE * * ==== Generate a 2-by-2 reflection, if needed. ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF( K.EQ.KTOP-1 ) THEN CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), $ S( 2*M22 ), V( 1, M22 ) ) BETA = V( 1, M22 ) CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) ELSE BETA = H( K+1, K ) V( 2, M22 ) = H( K+2, K ) CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF END IF * * ==== Multiply H by reflections from the left ==== * IF( ACCUM ) THEN JBOT = MIN( NDCOL, KBOT ) ELSE IF( WANTT ) THEN JBOT = N ELSE JBOT = KBOT END IF DO 30 J = MAX( KTOP, KRCOL ), JBOT MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) DO 20 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = DCONJG( V( 1, M ) )* $ ( H( K+1, J )+DCONJG( V( 2, M ) )* $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 20 CONTINUE 30 CONTINUE IF( BMP22 ) THEN K = KRCOL + 3*( M22-1 ) DO 40 J = MAX( K+1, KTOP ), JBOT REFSUM = DCONJG( V( 1, M22 ) )* $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* $ H( K+2, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 40 CONTINUE END IF * * ==== Multiply H by reflections from the right. * . Delay filling in the last row until the * . vigilant deflation check is complete. ==== * IF( ACCUM ) THEN JTOP = MAX( KTOP, INCOL ) ELSE IF( WANTT ) THEN JTOP = 1 ELSE JTOP = KTOP END IF DO 80 M = MTOP, MBOT IF( V( 1, M ).NE.ZERO ) THEN K = KRCOL + 3*( M-1 ) DO 50 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M ) ) H( J, K+3 ) = H( J, K+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 50 CONTINUE * IF( ACCUM ) THEN * * ==== Accumulate U. (If necessary, update Z later * . with with an efficient matrix-matrix * . multiply.) ==== * KMS = K - INCOL DO 60 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*DCONJG( V( 2, M ) ) U( J, KMS+3 ) = U( J, KMS+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 60 CONTINUE ELSE IF( WANTZ ) THEN * * ==== U is not accumulated, so update Z * . now by multiplying by reflections * . from the right. ==== * DO 70 J = ILOZ, IHIZ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M ) ) Z( J, K+3 ) = Z( J, K+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 70 CONTINUE END IF END IF 80 CONTINUE * * ==== Special case: 2-by-2 reflection (if needed) ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF ( V( 1, M22 ).NE.ZERO ) THEN DO 90 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* $ H( J, K+2 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M22 ) ) 90 CONTINUE * IF( ACCUM ) THEN KMS = K - INCOL DO 100 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ $ V( 2, M22 )*U( J, KMS+2 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*DCONJG( V( 2, M22 ) ) 100 CONTINUE ELSE IF( WANTZ ) THEN DO 110 J = ILOZ, IHIZ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* $ Z( J, K+2 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M22 ) ) 110 CONTINUE END IF END IF END IF * * ==== Vigilant deflation check ==== * MSTART = MTOP IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) $ MSTART = MSTART + 1 MEND = MBOT IF( BMP22 ) $ MEND = MEND + 1 IF( KRCOL.EQ.KBOT-2 ) $ MEND = MEND + 1 DO 120 M = MSTART, MEND K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) * * ==== The following convergence test requires that * . the tradition small-compared-to-nearby-diagonals * . criterion and the Ahues & Tisseur (LAWN 122, 1997) * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 * . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) IF( TST1.EQ.RZERO ) THEN IF( K.GE.KTOP+1 ) $ TST1 = TST1 + CABS1( H( K, K-1 ) ) IF( K.GE.KTOP+2 ) $ TST1 = TST1 + CABS1( H( K, K-2 ) ) IF( K.GE.KTOP+3 ) $ TST1 = TST1 + CABS1( H( K, K-3 ) ) IF( K.LE.KBOT-2 ) $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) IF( K.LE.KBOT-3 ) $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) IF( K.LE.KBOT-4 ) $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) END IF IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) $ THEN H12 = MAX( CABS1( H( K+1, K ) ), $ CABS1( H( K, K+1 ) ) ) H21 = MIN( CABS1( H( K+1, K ) ), $ CABS1( H( K, K+1 ) ) ) H11 = MAX( CABS1( H( K+1, K+1 ) ), $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) H22 = MIN( CABS1( H( K+1, K+1 ) ), $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) SCL = H11 + H12 TST2 = H22*( H11 / SCL ) * IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO END IF END IF 120 CONTINUE * * ==== Fill in the last row of each bulge. ==== * MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) DO 130 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) H( K+4, K+1 ) = -REFSUM H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) H( K+4, K+3 ) = H( K+4, K+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 130 CONTINUE * * ==== End of near-the-diagonal bulge chase. ==== * 140 CONTINUE * * ==== Use U (if accumulated) to update far-from-diagonal * . entries in H. If required, use U to update Z as * . well. ==== * IF( ACCUM ) THEN IF( WANTT ) THEN JTOP = 1 JBOT = N ELSE JTOP = KTOP JBOT = KBOT END IF IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN * * ==== Updates not exploiting the 2-by-2 block * . structure of U. K1 and NU keep track of * . the location and size of U in the special * . cases of introducing bulges and chasing * . bulges off the bottom. In these special * . cases and in case the number of shifts * . is NS = 2, there is no 2-by-2 block * . structure to exploit. ==== * K1 = MAX( 1, KTOP-INCOL ) NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 * * ==== Horizontal Multiply ==== * DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, $ LDWH ) CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, $ H( INCOL+K1, JCOL ), LDH ) 150 CONTINUE * * ==== Vertical multiply ==== * DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, $ H( JROW, INCOL+K1 ), LDH ) 160 CONTINUE * * ==== Z multiply (also vertical) ==== * IF( WANTZ ) THEN DO 170 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, $ Z( JROW, INCOL+K1 ), LDZ ) 170 CONTINUE END IF ELSE * * ==== Updates exploiting U's 2-by-2 block structure. * . (I2, I4, J2, J4 are the last rows and columns * . of the blocks.) ==== * I2 = ( KDU+1 ) / 2 I4 = KDU J2 = I4 - I2 J4 = KDU * * ==== KZS and KNZ deal with the band of zeros * . along the diagonal of one of the triangular * . blocks. ==== * KZS = ( J4-J2 ) - ( NS+1 ) KNZ = NS + 1 * * ==== Horizontal multiply ==== * DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) * * ==== Copy bottom of H to top+KZS of scratch ==== * (The first KZS rows get multiplied by zero.) ==== * CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), $ LDH, WH( KZS+1, 1 ), LDWH ) * * ==== Multiply by U21**H ==== * CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), $ LDWH ) * * ==== Multiply top of H by U11**H ==== * CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * * ==== Copy top of H to bottom of WH ==== * CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U21**H ==== * CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U22 ==== * CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, $ U( J2+1, I2+1 ), LDU, $ H( INCOL+1+J2, JCOL ), LDH, ONE, $ WH( I2+1, 1 ), LDWH ) * * ==== Copy it back ==== * CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, $ H( INCOL+1, JCOL ), LDH ) 180 CONTINUE * * ==== Vertical multiply ==== * DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) * * ==== Copy right of H to scratch (the first KZS * . columns get multiplied by zero) ==== * CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), $ LDH, WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U21 ==== * CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, $ LDWV ) * * ==== Copy left of H to right of scratch ==== * CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, $ WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U22 ==== * CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ H( JROW, INCOL+1+J2 ), LDH, $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), $ LDWV ) * * ==== Copy it back ==== * CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ H( JROW, INCOL+1 ), LDH ) 190 CONTINUE * * ==== Multiply Z (also vertical) ==== * IF( WANTZ ) THEN DO 200 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) * * ==== Copy right of Z to left of scratch (first * . KZS columns get multiplied by zero) ==== * CALL ZLACPY( 'ALL', JLEN, KNZ, $ Z( JROW, INCOL+1+J2 ), LDZ, $ WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U12 ==== * CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, $ LDWV ) CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, $ WV, LDWV ) * * ==== Copy left of Z to right of scratch ==== * CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), $ LDZ, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), $ LDWV ) * * ==== Multiply by U22 ==== * CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ Z( JROW, INCOL+1+J2 ), LDZ, $ U( J2+1, I2+1 ), LDU, ONE, $ WV( 1, 1+I2 ), LDWV ) * * ==== Copy the result back to Z ==== * CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ Z( JROW, INCOL+1 ), LDZ ) 200 CONTINUE END IF END IF END IF 210 CONTINUE * * ==== End of ZLAQR5 ==== * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlarf.f000066400000000000000000000142671522610125300261020ustar00rootroot00000000000000*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * COMPLEX*16 TAU * .. * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARF applies a complex elementary reflector H to a complex M-by-N *> matrix C, from either the left or the right. H is represented in the *> form *> *> H = I - tau * v * v**H *> *> where tau is a complex scalar and v is a complex vector. *> *> If tau = 0, then H is taken to be the unit matrix. *> *> To apply H**H, supply conjg(tau) instead *> tau. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of H. V is not used if *> TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \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, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER INCV, LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZGERC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAZLR, ILAZLC EXTERNAL LSAME, ILAZLR, ILAZLC * .. * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) LASTV = 0 LASTC = 0 IF( TAU.NE.ZERO ) THEN * Set up variables for scanning V. LASTV begins pointing to the end * of V. IF( APPLYLEFT ) THEN LASTV = M ELSE LASTV = N END IF IF( INCV.GT.0 ) THEN I = 1 + (LASTV-1) * INCV ELSE I = 1 END IF * Look for the last non-zero row in V. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO IF( APPLYLEFT ) THEN * Scan for the last non-zero column in C(1:lastv,:). LASTC = ILAZLC(LASTV, N, C, LDC) ELSE * Scan for the last non-zero row in C(:,1:lastv). LASTC = ILAZLR(M, LASTV, C, LDC) END IF END IF * Note that lastc.eq.0 renders the BLAS operations null; no special * case is needed at this level. IF( APPLYLEFT ) THEN * * Form H * C * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) * CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, $ C, LDC, V, INCV, ZERO, WORK, 1 ) * * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H * CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) * CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, $ V, INCV, ZERO, WORK, 1 ) * * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H * CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of ZLARF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlarfb.f000066400000000000000000000532511522610125300262400ustar00rootroot00000000000000*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARFB applies a complex block reflector H or its transpose H**H to a *> complex M-by-N matrix C, from either the left or the right. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**H from the Left *> = 'R': apply H or H**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'C': apply H**H (Conjugate transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columnwise *> = 'R': Rowwise *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T (= the number of elementary *> reflectors whose product defines the block reflector). *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \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 H*C or H**H*C or C*H or C*H**H. *> \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, dimension (LDWORK,K) *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= max(1,N); *> if SIDE = 'R', LDWORK >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2013 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored; the corresponding *> array elements are modified but restored on exit. The rest of the *> array is not used. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 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 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C1**H * DO 10 J = 1, K CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**H * V2 * CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C( K+1, 1 ), LDC, $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * IF( N.GT.K ) THEN * * C2 := C2 - W * V2**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C2**H * DO 70 J = 1, K CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1 * CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T**H or W * T * CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, C, LDC ) END IF * * W := W * V2**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * IF( N.GT.K ) THEN * * C1 := C1 - W * V1**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, $ C, LDC ) END IF * * W := W * V2**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C1**H * DO 130 J = 1, K CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**H * V2**H * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T**H or W * T * CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * IF( M.GT.K ) THEN * * C2 := C2 - V2**H * W**H * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ K, N-K, ONE, C( 1, K+1 ), LDC, $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C2**H * DO 190 J = 1, K CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, C, $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * IF( M.GT.K ) THEN * * C1 := C1 - V1**H * W**H * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', M-K, N, K, -ONE, V, $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T or W * T**H * CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of ZLARFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlarfg.f000066400000000000000000000124271522610125300262450ustar00rootroot00000000000000*> \brief \b ZLARFG generates an elementary reflector (Householder matrix). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARFG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX*16 ALPHA, TAU * .. * .. Array Arguments .. * COMPLEX*16 X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARFG generates a complex elementary reflector H of order n, such *> that *> *> H**H * ( alpha ) = ( beta ), H**H * H = I. *> ( x ) ( 0 ) *> *> where alpha and beta are scalars, with beta real, and x is an *> (n-1)-element complex vector. H is represented in the form *> *> H = I - tau * ( 1 ) * ( 1 v**H ) , *> ( v ) *> *> where tau is a complex scalar and v is a complex (n-1)-element *> vector. Note that H is not hermitian. *> *> If the elements of x are all zero and alpha is real, then tau = 0 *> and H is taken to be the unit matrix. *> *> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the elementary reflector. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is COMPLEX*16 *> On entry, the value alpha. *> On exit, it is overwritten with the value beta. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX*16 array, dimension *> (1+(N-2)*abs(INCX)) *> On entry, the vector x. *> On exit, it is overwritten with the vector v. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is COMPLEX*16 *> The value tau. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N COMPLEX*16 ALPHA, TAU * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 COMPLEX*16 ZLADIV EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN * .. * .. External Subroutines .. EXTERNAL ZDSCAL, ZSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = DZNRM2( N-1, X, INCX ) ALPHR = DBLE( ALPHA ) ALPHI = DIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) RSAFMN = ONE / SAFMIN * KNT = 0 IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * 10 CONTINUE KNT = KNT + 1 CALL ZDSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DZNRM2( N-1, X, INCX ) ALPHA = DCMPLX( ALPHR, ALPHI ) BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) END IF TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * DO 20 J = 1, KNT BETA = BETA*SAFMIN 20 CONTINUE ALPHA = BETA END IF * RETURN * * End of ZLARFG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlarft.f000066400000000000000000000241551522610125300262630ustar00rootroot00000000000000*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARFT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARFT forms the triangular factor T of a complex block reflector H *> of order n, which is defined as a product of k elementary reflectors. *> *> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; *> *> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. *> *> If STOREV = 'C', the vector which defines the elementary reflector *> H(i) is stored in the i-th column of the array V, and *> *> H = I - V * T * V**H *> *> If STOREV = 'R', the vector which defines the elementary reflector *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**H * T * V *> \endverbatim * * Arguments: * ========== * *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies the order in which the elementary reflectors are *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): *> = 'C': columnwise *> = 'R': rowwise *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the block reflector H. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the triangular factor T (= the number of *> elementary reflectors). K >= 1. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,N) if STOREV = 'R' *> The matrix V. See further details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,K) *> The k by k triangular factor T of the block reflector. *> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is *> lower triangular. The rest of the array is not used. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 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 DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZTRMV, ZGEMM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN PREVLASTV = N DO I = 1, K PREVLASTV = MAX( PREVLASTV, I ) IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = 1, I T( J, I ) = ZERO END DO ELSE * * general case * IF( LSAME( STOREV, 'C' ) ) THEN * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) 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, $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) ELSE * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) 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 ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) IF( I.GT.1 ) THEN PREVLASTV = MAX( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF END DO ELSE PREVLASTV = 1 DO I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = I, K T( J, I ) = ZERO END DO ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) 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) * CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I, $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), $ 1, ONE, T( I+1, I ), 1 ) ELSE * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) 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 ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) IF( I.GT.1 ) THEN PREVLASTV = MIN( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF T( I, I ) = TAU( I ) END IF END DO END IF RETURN * * End of ZLARFT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlarfx.f000066400000000000000000000507701522610125300262710ustar00rootroot00000000000000*> \brief \b ZLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARFX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N * COMPLEX*16 TAU * .. * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARFX applies a complex elementary reflector H to a complex m by n *> matrix C, from either the left or the right. H is represented in the *> form *> *> H = I - tau * v * v**H *> *> where tau is a complex scalar and v is a complex vector. *> *> If tau = 0, then H is taken to be the unit matrix *> *> This version uses inline code if H has order < 11. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension (M) if SIDE = 'L' *> or (N) if SIDE = 'R' *> The vector v in the representation of H. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 *> The value tau in the representation of H. *> \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 the matrix H * C if SIDE = 'L', *> or C * H if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDA >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> WORK is not referenced if H has order < 11. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.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 INTEGER LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), 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 COMPLEX*16 SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) V9 = DCONJG( V( 9 ) ) T9 = TAU*DCONJG( V9 ) DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) V9 = DCONJG( V( 9 ) ) T9 = TAU*DCONJG( V9 ) V10 = DCONJG( V( 10 ) ) T10 = TAU*DCONJG( V10 ) DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) V9 = V( 9 ) T9 = TAU*DCONJG( V9 ) DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) V9 = V( 9 ) T9 = TAU*DCONJG( V9 ) V10 = V( 10 ) T10 = TAU*DCONJG( V10 ) DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of ZLARFX * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlarnv.f000066400000000000000000000127571522610125300263020ustar00rootroot00000000000000*> \brief \b ZLARNV returns a vector of random numbers from a uniform or normal distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARNV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER IDIST, N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * COMPLEX*16 X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARNV returns a vector of n random complex numbers from a uniform or *> normal distribution. *> \endverbatim * * Arguments: * ========== * *> \param[in] IDIST *> \verbatim *> IDIST is INTEGER *> Specifies the distribution of the random numbers: *> = 1: real and imaginary parts each uniform (0,1) *> = 2: real and imaginary parts each uniform (-1,1) *> = 3: real and imaginary parts each normal (0,1) *> = 4: uniformly distributed on the disc abs(z) < 1 *> = 5: uniformly distributed on the circle abs(z) = 1 *> \endverbatim *> *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is COMPLEX*16 array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine calls the auxiliary routine DLARUV to generate random *> real numbers from a uniform (0,1) distribution, in batches of up to *> 128 using vectorisable code. The Box-Muller method is used to *> transform numbers from a uniform to a normal distribution. *> \endverbatim *> * ===================================================================== SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.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 IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX*16 X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) INTEGER LV PARAMETER ( LV = 128 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IV * .. * .. Local Arrays .. DOUBLE PRECISION U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, EXP, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL DLARUV * .. * .. Executable Statements .. * DO 60 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) * * Call DLARUV to generate 2*IL real numbers from a uniform (0,1) * distribution (2*IL <= LV) * CALL DLARUV( ISEED, 2*IL, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = DCMPLX( U( 2*I-1 ), U( 2*I ) ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = DCMPLX( TWO*U( 2*I-1 )-ONE, $ TWO*U( 2*I )-ONE ) 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) ) 30 CONTINUE ELSE IF( IDIST.EQ.4 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit disk * DO 40 I = 1, IL X( IV+I-1 ) = SQRT( U( 2*I-1 ) )* $ EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) ) 40 CONTINUE ELSE IF( IDIST.EQ.5 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit circle * DO 50 I = 1, IL X( IV+I-1 ) = EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) ) 50 CONTINUE END IF 60 CONTINUE RETURN * * End of ZLARNV * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlartg.f000066400000000000000000000163221522610125300262610ustar00rootroot00000000000000*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLARTG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARTG( F, G, CS, SN, R ) * * .. Scalar Arguments .. * DOUBLE PRECISION CS * COMPLEX*16 F, G, R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLARTG generates a plane rotation so that *> *> [ CS SN ] [ F ] [ R ] *> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. *> [ -SN CS ] [ G ] [ 0 ] *> *> This is a faster version of the BLAS1 routine ZROTG, except for *> the following differences: *> F and G are unchanged on return. *> If G=0, then CS=1 and SN=0. *> If F=0, then CS=0 and SN is chosen so that R is real. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is COMPLEX*16 *> The first component of vector to be rotated. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is COMPLEX*16 *> The second component of vector to be rotated. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is COMPLEX*16 *> The sine of the rotation. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is COMPLEX*16 *> The nonzero component of the rotated vector. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel *> *> This version has a few statements commented out for thread safety *> (machine parameters are computed on each entry). 10 feb 03, SJH. *> \endverbatim *> * ===================================================================== SUBROUTINE ZLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.7.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 .. DOUBLE PRECISION CS COMPLEX*16 F, G, R, SN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION TWO, ONE, ZERO PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE COMPLEX*16 FF, FS, GS * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 LOGICAL DISNAN EXTERNAL DLAMCH, DLAPY2, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, $ MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G COUNT = 0 IF( SCALE.GE.SAFMX2 ) THEN 10 CONTINUE COUNT = COUNT + 1 FS = FS*SAFMN2 GS = GS*SAFMN2 SCALE = SCALE*SAFMN2 IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN CS = ONE SN = CZERO R = F RETURN END IF 20 CONTINUE COUNT = COUNT - 1 FS = FS*SAFMX2 GS = GS*SAFMX2 SCALE = SCALE*SAFMX2 IF( SCALE.LE.SAFMN2 ) $ GO TO 20 END IF F2 = ABSSQ( FS ) G2 = ABSSQ( GS ) IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN * * This is a rare case: F is very small. * IF( F.EQ.CZERO ) THEN CS = ZERO R = DLAPY2( DBLE( G ), DIMAG( G ) ) * Do complex/real division explicitly with two real divisions D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) RETURN END IF F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) * G2 and G2S are accurate * G2 is at least SAFMIN, and G2S is at least SAFMN2 G2S = SQRT( G2 ) * Error in CS from underflow in F2S is at most * UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS * If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, * and so CS .lt. sqrt(SAFMIN) * If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN * and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) * Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S CS = F2S / G2S * Make sure abs(FF) = 1 * Do complex/real division explicitly with 2 real divisions IF( ABS1( F ).GT.ONE ) THEN D = DLAPY2( DBLE( F ), DIMAG( F ) ) FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) ELSE DR = SAFMX2*DBLE( F ) DI = SAFMX2*DIMAG( F ) D = DLAPY2( DR, DI ) FF = DCMPLX( DR / D, DI / D ) END IF SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) R = CS*F + SN*G ELSE * * This is the most common case. * Neither F2 nor F2/G2 are less than SAFMIN * F2S cannot overflow, and it is accurate * F2S = SQRT( ONE+G2 / F2 ) * Do the F2S(real)*FS(complex) multiply with two real multiplies R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) CS = ONE / F2S D = F2 + G2 * Do complex/real division explicitly with two real divisions SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) SN = SN*DCONJG( GS ) IF( COUNT.NE.0 ) THEN IF( COUNT.GT.0 ) THEN DO 30 I = 1, COUNT R = R*SAFMX2 30 CONTINUE ELSE DO 40 I = 1, -COUNT R = R*SAFMN2 40 CONTINUE END IF END IF END IF RETURN * * End of ZLARTG * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlascl.f000066400000000000000000000234351522610125300262510ustar00rootroot00000000000000*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLASCL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLASCL multiplies the M by N complex matrix A by the real scalar *> CTO/CFROM. This is done without over/underflow as long as the final *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that *> A may be full, upper triangular, lower triangular, upper Hessenberg, *> or banded. *> \endverbatim * * Arguments: * ========== * *> \param[in] TYPE *> \verbatim *> TYPE is CHARACTER*1 *> TYPE indices the storage type of the input matrix. *> = 'G': A is a full matrix. *> = 'L': A is a lower triangular matrix. *> = 'U': A is an upper triangular matrix. *> = 'H': A is an upper Hessenberg matrix. *> = 'B': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the lower *> half stored. *> = 'Q': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the upper *> half stored. *> = 'Z': A is a band matrix with lower bandwidth KL and upper *> bandwidth KU. See ZGBTRF for storage details. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The lower bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The upper bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] CFROM *> \verbatim *> CFROM is DOUBLE PRECISION *> \endverbatim *> *> \param[in] CTO *> \verbatim *> CTO is DOUBLE PRECISION *> *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed *> without over/underflow if the final result CTO*A(I,J)/CFROM *> can be represented without over/underflow. CFROM must be *> nonzero. *> \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,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> The matrix to be multiplied by CTO/CFROM. See TYPE for the *> storage type. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> 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 *> \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 June 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 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 TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME, DISNAN DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN INFO = -4 ELSE IF( DISNAN(CTO) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM IF( CFROM1.EQ.CFROMC ) THEN ! CFROMC is an inf. Multiply by a correctly signed zero for ! finite CTOC, or a NaN if CTOC is infinite. MUL = CTOC / CFROMC DONE = .TRUE. CTO1 = CTOC ELSE CTO1 = CTOC / BIGNUM IF( CTO1.EQ.CTOC ) THEN ! CTOC is either 0 or an inf. In both cases, CTOC itself ! serves as the correct multiplication factor. MUL = CTOC DONE = .TRUE. CFROMC = ONE ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of ZLASCL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaset.f000066400000000000000000000113601522610125300262550ustar00rootroot00000000000000*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLASET + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N * COMPLEX*16 ALPHA, BETA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLASET initializes a 2-D array A to BETA on the diagonal and *> ALPHA on the offdiagonals. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be set. *> = 'U': Upper triangular part is set. The lower triangle *> is unchanged. *> = 'L': Lower triangular part is set. The upper triangle *> is unchanged. *> Otherwise: All of the matrix A is set. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the number of rows of A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the number of columns of A. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is COMPLEX*16 *> All the offdiagonal array elements are set to ALPHA. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is COMPLEX*16 *> All the diagonal array elements are set to BETA. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the m by n matrix A. *> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; *> A(i,i) = BETA , 1 <= i <= min(m,n) *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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, M, N COMPLEX*16 ALPHA, BETA * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the diagonal to BETA and the strictly upper triangular * part of the array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( N, M ) A( I, I ) = BETA 30 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the diagonal to BETA and the strictly lower triangular * part of the array to ALPHA. * DO 50 J = 1, MIN( M, N ) DO 40 I = J + 1, M A( I, J ) = ALPHA 40 CONTINUE 50 CONTINUE DO 60 I = 1, MIN( N, M ) A( I, I ) = BETA 60 CONTINUE * ELSE * * Set the array to BETA on the diagonal and ALPHA on the * offdiagonal. * DO 80 J = 1, N DO 70 I = 1, M A( I, J ) = ALPHA 70 CONTINUE 80 CONTINUE DO 90 I = 1, MIN( M, N ) A( I, I ) = BETA 90 CONTINUE END IF * RETURN * * End of ZLASET * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlasr.f000066400000000000000000000354331522610125300261150ustar00rootroot00000000000000*> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLASR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), S( * ) * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLASR applies a sequence of real plane rotations to a complex 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 ) *> ( c(k) s(k) ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) *> ( 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 ) *> ( c(k) s(k) ) *> ( 1 ) *> ( ... ) *> ( 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> Specifies whether the plane rotation matrix P is applied to *> A on the left or the right. *> = 'L': Left, compute A := P*A *> = 'R': Right, compute A:= A*P**T *> \endverbatim *> *> \param[in] PIVOT *> \verbatim *> PIVOT is CHARACTER*1 *> Specifies the plane for which P(k) is a plane rotation *> matrix. *> = 'V': Variable pivot, the plane (k,k+1) *> = 'T': Top pivot, the plane (1,k+1) *> = 'B': Bottom pivot, the plane (k,z) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies whether P is a forward or backward sequence of *> plane rotations. *> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) *> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. If m <= 1, an immediate *> return is effected. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. If n <= 1, an *> immediate return is effected. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The cosines c(k) of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The sines s(k) of the plane rotations. The 2-by-2 plane *> rotation part of the matrix P(k), R(k), has the form *> R(k) = ( c(k) s(k) ) *> ( -s(k) c(k) ). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> The M-by-N matrix A. On exit, A is overwritten by P*A if *> SIDE = 'R' or by A*P**T if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.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 DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( * ), S( * ) COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP COMPLEX*16 TEMP * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P**T * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of ZLASR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlassq.f000066400000000000000000000112151522610125300262670ustar00rootroot00000000000000*> \brief \b ZLASSQ updates a sum of squares represented in scaled form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLASSQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. * COMPLEX*16 X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLASSQ returns the values scl and ssq such that *> *> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, *> *> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is *> assumed to be at least unity and the value of ssq will then satisfy *> *> 1.0 .le. ssq .le. ( sumsq + 2*n ). *> *> scale is assumed to be non-negative and scl returns the value *> *> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), *> i *> *> scale and sumsq must be supplied in SCALE and SUMSQ respectively. *> SCALE and SUMSQ are overwritten by scl and ssq respectively. *> *> The routine makes only one pass through the vector X. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements to be used from the vector X. *> \endverbatim *> *> \param[in] X *> \verbatim *> X is COMPLEX*16 array, dimension (N) *> The vector x as described above. *> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of the vector X. *> INCX > 0. *> \endverbatim *> *> \param[in,out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On entry, the value scale in the equation above. *> On exit, SCALE is overwritten with the value scl . *> \endverbatim *> *> \param[in,out] SUMSQ *> \verbatim *> SUMSQ is DOUBLE PRECISION *> On entry, the value sumsq in the equation above. *> On exit, SUMSQ is overwritten with the value ssq . *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION TEMP1 * .. * .. External Functions .. LOGICAL DISNAN EXTERNAL DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX TEMP1 = ABS( DBLE( X( IX ) ) ) IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF TEMP1 = ABS( DIMAG( X( IX ) ) ) IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF 10 CONTINUE END IF * RETURN * * End of ZLASSQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlaswp.f000066400000000000000000000117231522610125300262760ustar00rootroot00000000000000*> \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLASWP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLASWP performs a series of row interchanges on the matrix A. *> One row interchange is initiated for each of rows K1 through K2 of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the matrix of column dimension N to which the row *> interchanges will be applied. *> On exit, the permuted matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> \endverbatim *> *> \param[in] K1 *> \verbatim *> K1 is INTEGER *> The first element of IPIV for which a row interchange will *> be done. *> \endverbatim *> *> \param[in] K2 *> \verbatim *> K2 is INTEGER *> (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 (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 *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of IPIV. If IPIV *> is negative, the pivots are applied in reverse order. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by *> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA *> \endverbatim *> * ===================================================================== SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.7.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 INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 COMPLEX*16 TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of ZLASWP * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlatdf.f000066400000000000000000000250611522610125300262420ustar00rootroot00000000000000*> \brief \b ZLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLATDF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) * * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * DOUBLE PRECISION RDSCAL, RDSUM * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * COMPLEX*16 RHS( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLATDF computes the contribution to the reciprocal Dif-estimate *> by solving for x in Z * x = b, where b is chosen such that the norm *> of x is as large as possible. It is assumed that LU decomposition *> of Z has been computed by ZGETC2. On entry RHS = f holds the *> contribution from earlier solved sub-systems, and on return RHS = x. *> *> The factorization of Z returned by ZGETC2 has the form *> Z = P * L * U * Q, where P and Q are permutation matrices. L is lower *> triangular with unit diagonal elements and U is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> IJOB = 2: First compute an approximative null-vector e *> of Z using ZGECON, e is normalized and solve for *> 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 chosen as either +1 or *> -1. Default. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Z. *> \endverbatim *> *> \param[in] Z *> \verbatim *> 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 *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> 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). *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is DOUBLE PRECISION *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by ZTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is DOUBLE PRECISION *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when ZTGSY2 is called by *> ZTGSYL. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> This routine is a further developed implementation of algorithm *> BSOLVE in [1] using complete pivoting in the LU factorization. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] Bo Kagstrom and Lars Westin, *> Generalized Schur Methods with Condition Estimators for *> Solving the Generalized Sylvester Equation, IEEE Transactions *> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. *>\n *> [2] Peter Poromaa, *> On Efficient and Robust Estimators for the Separation *> between two Regular Matrix Pairs with Applications in *> Condition Estimation. Report UMINF-95.05, Department of *> Computing Science, Umea University, S-901 87 Umea, Sweden, *> 1995. * * ===================================================================== SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * * -- LAPACK auxiliary routine (version 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 .. INTEGER IJOB, LDZ, N DOUBLE PRECISION RDSCAL, RDSUM * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) COMPLEX*16 RHS( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXDIM PARAMETER ( MAXDIM = 2 ) 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 .. INTEGER I, INFO, J, K DOUBLE PRECISION RTEMP, SCALE, SMINU, SPLUS COMPLEX*16 BM, BP, PMONE, TEMP * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( MAXDIM ) COMPLEX*16 WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZCOPY, ZGECON, ZGESC2, ZLASSQ, ZLASWP, $ ZSCAL * .. * .. External Functions .. DOUBLE PRECISION DZASUM COMPLEX*16 ZDOTC EXTERNAL DZASUM, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, SQRT * .. * .. Executable Statements .. * IF( IJOB.NE.2 ) THEN * * Apply permutations IPIV to RHS * CALL ZLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) * * Solve for L-part choosing RHS either to +1 or -1. * PMONE = -CONE DO 10 J = 1, N - 1 BP = RHS( J ) + CONE BM = RHS( J ) - CONE SPLUS = ONE * * Lockahead for L- part RHS(1:N-1) = +-1 * SPLUS and SMIN computed more efficiently than in BSOLVE[1]. * SPLUS = SPLUS + DBLE( ZDOTC( N-J, Z( J+1, J ), 1, Z( J+1, $ J ), 1 ) ) SMINU = DBLE( ZDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) ) SPLUS = SPLUS*DBLE( RHS( J ) ) IF( SPLUS.GT.SMINU ) THEN RHS( J ) = BP ELSE IF( SMINU.GT.SPLUS ) THEN RHS( J ) = BM ELSE * * In this case the updating sums are equal and we can * choose RHS(J) +1 or -1. The first time this happens we * choose -1, thereafter +1. This is a simple way to get * good estimates of matrices like Byers well-known example * (see [1]). (Not done in BSOLVE.) * RHS( J ) = RHS( J ) + PMONE PMONE = CONE END IF * * Compute the remaining r.h.s. * TEMP = -RHS( J ) CALL ZAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) 10 CONTINUE * * Solve for U- part, lockahead for RHS(N) = +-1. This is not done * In BSOLVE and will hopefully give us a better estimate because * any ill-conditioning of the original matrix is transfered to U * and not to L. U(N, N) is an approximation to sigma_min(LU). * CALL ZCOPY( N-1, RHS, 1, WORK, 1 ) WORK( N ) = RHS( N ) + CONE RHS( N ) = RHS( N ) - CONE SPLUS = ZERO SMINU = ZERO DO 30 I = N, 1, -1 TEMP = CONE / Z( I, I ) WORK( I ) = WORK( I )*TEMP RHS( I ) = RHS( I )*TEMP DO 20 K = I + 1, N WORK( I ) = WORK( I ) - WORK( K )*( Z( I, K )*TEMP ) RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) 20 CONTINUE SPLUS = SPLUS + ABS( WORK( I ) ) SMINU = SMINU + ABS( RHS( I ) ) 30 CONTINUE IF( SPLUS.GT.SMINU ) $ CALL ZCOPY( N, WORK, 1, RHS, 1 ) * * Apply the permutations JPIV to the computed solution (RHS) * CALL ZLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) * * Compute the sum of squares * CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM ) RETURN END IF * * ENTRY IJOB = 2 * * Compute approximate nullvector XM of Z * CALL ZGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO ) CALL ZCOPY( N, WORK( N+1 ), 1, XM, 1 ) * * Compute RHS * CALL ZLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) TEMP = CONE / SQRT( ZDOTC( N, XM, 1, XM, 1 ) ) CALL ZSCAL( N, TEMP, XM, 1 ) CALL ZCOPY( N, XM, 1, XP, 1 ) CALL ZAXPY( N, CONE, RHS, 1, XP, 1 ) CALL ZAXPY( N, -CONE, XM, 1, RHS, 1 ) CALL ZGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE ) CALL ZGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE ) IF( DZASUM( N, XP, 1 ).GT.DZASUM( N, RHS, 1 ) ) $ CALL ZCOPY( N, XP, 1, RHS, 1 ) * * Compute the sum of squares * CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM ) RETURN * * End of ZLATDF * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlatrs.f000066400000000000000000000725351522610125300263050ustar00rootroot00000000000000*> \brief \b ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLATRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION CNORM( * ) * COMPLEX*16 A( LDA, * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZLATRS solves one of the triangular systems *> *> A * x = s*b, A**T * x = s*b, or A**H * x = s*b, *> *> with scaling to prevent overflow. Here A is an upper or lower *> triangular matrix, A**T denotes the transpose of A, A**H denotes the *> conjugate transpose of A, x and b are n-element vectors, and s is a *> scaling factor, usually less than or equal to 1, chosen so that the *> components of x will be less than the overflow threshold. If the *> unscaled problem will not cause overflow, the Level 2 BLAS routine *> ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), *> then s is set to 0 and a non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T * x = s*b (Transpose) *> = 'C': Solve A**H * x = s*b (Conjugate transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \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) *> The triangular matrix A. If UPLO = 'U', the leading n by n *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading n by n lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max (1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is COMPLEX*16 array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scaling factor s for the triangular system *> A * x = s*b, A**T * x = s*b, or A**H * x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is DOUBLE PRECISION array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-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 November 2017 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, ZTRSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T *x = b or *> A**H *x = b. The basic algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION CNORM( * ) COMPLEX*16 A( LDA, * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, $ XBND, XJ, XMAX COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DLAMCH, DZASUM COMPLEX*16 ZDOTC, ZDOTU, ZLADIV EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, $ ZDOTU, ZLADIV * .. * .. External Subroutines .. EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV, DLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1, CABS2 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + $ ABS( DIMAG( ZDUM ) / 2.D0 ) * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM/2. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM*HALF ) THEN TSCAL = ONE ELSE TSCAL = HALF / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine ZTRSV can be used. * XMAX = ZERO DO 30 J = 1, N XMAX = MAX( XMAX, CABS2( X( J ) ) ) 30 CONTINUE XBND = XMAX * IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 60 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = G(j-1) / abs(A(j,j)) * XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF * IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 40 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 50 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 50 CONTINUE END IF 60 CONTINUE * ELSE * * Compute the growth in A**T * x = b or A**H * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 90 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF 70 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 80 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 80 CONTINUE END IF 90 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = ( BIGNUM*HALF ) / XMAX CALL ZDSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM ELSE XMAX = XMAX*TWO END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 120 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 110 END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 100 I = 1, N X( I ) = ZERO 100 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 110 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL ZDSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = IZAMAX( J-1, X, 1 ) XMAX = CABS1( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + IZAMAX( N-J, X( J+1 ), 1 ) XMAX = CABS1( X( I ) ) END IF END IF 120 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * x = b * DO 170 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = ZLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.DCMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call ZDOTU to perform the dot product. * IF( UPPER ) THEN CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 130 I = 1, J - 1 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE ELSE IF( J.LT.N ) THEN DO 140 I = J + 1, N CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 140 CONTINUE END IF END IF * IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 160 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**T *x = 0. * DO 150 I = 1, N X( I ) = ZERO 150 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 160 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 170 CONTINUE * ELSE * * Solve A**H * x = b * DO 220 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = DCONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = ZLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.DCMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call ZDOTC to perform the dot product. * IF( UPPER ) THEN CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 180 I = 1, J - 1 CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* $ X( I ) 180 CONTINUE ELSE IF( J.LT.N ) THEN DO 190 I = J + 1, N CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* $ X( I ) 190 CONTINUE END IF END IF * IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = DCONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 210 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**H *x = 0. * DO 200 I = 1, N X( I ) = ZERO 200 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 210 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 220 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of ZLATRS * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zlatsqr.f000066400000000000000000000171431522610125300264600ustar00rootroot00000000000000*> \brief \b ZLATSQR * * 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 *> *> ZLATSQR computes a blocked Tall-Skinny QR factorization of *> a complex M-by-N matrix A for M >= N: *> *> A = Q * ( R ), *> ( 0 ) *> *> where: *> *> Q is a M-by-M orthogonal matrix, stored on exit in an implicit *> form in the elements below the digonal of the array A and in *> the elemenst of the array T; *> *> R is an upper-triangular N-by-N matrix, stored on exit in *> the elements on and above the diagonal of the array A. *> *> 0 is a (M-N)-by-N zero matrix, and is not stored. *> *> \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.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- * November 2019 * * .. Scalar Arguments .. INTEGER 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zsteqr.f000066400000000000000000000366101522610125300263100ustar00rootroot00000000000000*> \brief \b ZSTEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZSTEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a *> symmetric tridiagonal matrix using the implicit QL or QR method. *> The eigenvectors of a full or band complex Hermitian matrix can also *> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this *> matrix to tridiagonal form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'V': Compute eigenvalues and eigenvectors of the original *> Hermitian matrix. On entry, Z must contain the *> unitary matrix used to reduce the original matrix *> to tridiagonal form. *> = 'I': Compute eigenvalues and eigenvectors of the *> tridiagonal matrix. Z is initialized to the identity *> matrix. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', then Z contains the unitary *> matrix used in the reduction to tridiagonal form. *> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the *> orthonormal eigenvectors of the original Hermitian matrix, *> and if COMPZ = 'I', Z contains the orthonormal eigenvectors *> of the symmetric tridiagonal matrix. *> If COMPZ = '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 *> eigenvectors are desired, then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) *> If COMPZ = 'N', then WORK 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: the algorithm has failed to find all the eigenvalues in *> a total of 30*N iterations; if INFO = i, then i *> elements of E have not converged to zero; on exit, D *> and E contain the elements of a symmetric tridiagonal *> matrix which is unitarily similar to the original *> matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, 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 COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) COMPLEX*16 Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, $ ZLASET, ZLASR, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = CONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.EQ.NMAXIT ) THEN DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE RETURN END IF GO TO 10 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF RETURN * * End of ZSTEQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztgevc.f000066400000000000000000000555151522610125300262670ustar00rootroot00000000000000*> \brief \b ZTGEVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTGEVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTGEVC computes some or all of the right and/or left eigenvectors of *> 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. *> If Q and Z are the unitary 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: * ========== * *> \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, *> specified 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 matrices S and P. N >= 0. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is COMPLEX*16 array, dimension (LDS,N) *> The upper triangular matrix S from a generalized Schur *> factorization, as computed by ZHGEQZ. *> \endverbatim *> *> \param[in] LDS *> \verbatim *> LDS is INTEGER *> The leading dimension of array S. LDS >= max(1,N). *> \endverbatim *> *> \param[in] P *> \verbatim *> P is COMPLEX*16 array, dimension (LDP,N) *> The upper triangular matrix P from a generalized Schur *> factorization, as computed by ZHGEQZ. P must have real *> diagonal elements. *> \endverbatim *> *> \param[in] LDP *> \verbatim *> LDP is INTEGER *> The leading dimension of array P. LDP >= 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 left Schur vectors returned by ZHGEQZ). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of (S,P) 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 array VL. LDVL >= 1, and if *> SIDE = 'L' or 'l' or 'B' 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 Z *> of right Schur vectors returned by ZHGEQZ). *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Z*X; *> if HOWMNY = 'S', the right eigenvectors of (S,P) 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 (2*N) *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is DOUBLE PRECISION array, dimension (2*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 complex16GEcomputational * * ===================================================================== SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, 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 HOWMNY, SIDE INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 P( LDP, * ), S( LDS, * ), 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 ) ) * .. * .. Local Scalars .. LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP, $ LSA, LSB INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC, $ J, JE, JR DOUBLE PRECISION ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG, $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA, $ SCALE, SMALL, TEMP, ULP, XMAX COMPLEX*16 BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH COMPLEX*16 ZLADIV EXTERNAL LSAME, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZGEMV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) * .. * .. Executable Statements .. * * Decode and Test the input parameters * IF( LSAME( HOWMNY, 'A' ) ) THEN IHWMNY = 1 ILALL = .TRUE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. ELSE IHWMNY = -1 END IF * IF( LSAME( SIDE, 'R' ) ) THEN ISIDE = 1 COMPL = .FALSE. COMPR = .TRUE. ELSE IF( LSAME( SIDE, 'L' ) ) THEN ISIDE = 2 COMPL = .TRUE. COMPR = .FALSE. ELSE IF( LSAME( SIDE, 'B' ) ) THEN ISIDE = 3 COMPL = .TRUE. COMPR = .TRUE. ELSE ISIDE = -1 END IF * INFO = 0 IF( ISIDE.LT.0 ) THEN INFO = -1 ELSE IF( IHWMNY.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGEVC', -INFO ) RETURN END IF * * Count the number of eigenvectors * IF( .NOT.ILALL ) THEN IM = 0 DO 10 J = 1, N IF( SELECT( J ) ) $ IM = IM + 1 10 CONTINUE ELSE IM = N END IF * * Check diagonal of B * ILBBAD = .FALSE. DO 20 J = 1, N IF( DIMAG( P( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * IF( ILBBAD ) THEN INFO = -7 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN INFO = -12 ELSE IF( MM.LT.IM ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGEVC', -INFO ) RETURN END IF * * Quick return if possible * M = IM IF( N.EQ.0 ) $ RETURN * * Machine Constants * SAFMIN = DLAMCH( 'Safe minimum' ) BIG = ONE / SAFMIN CALL DLABAD( SAFMIN, BIG ) ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) SMALL = SAFMIN*N / ULP BIG = ONE / SMALL BIGNUM = ONE / ( SAFMIN*N ) * * Compute the 1-norm of each column of the strictly upper triangular * part of A and B to check for possible overflow in the triangular * solver. * ANORM = ABS1( S( 1, 1 ) ) BNORM = ABS1( P( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) 30 CONTINUE ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) BSCALE = ONE / MAX( BNORM, SAFMIN ) * * Left eigenvectors * IF( COMPL ) THEN IEIG = 0 * * Main loop over eigenvalues * DO 140 JE = 1, N IF( ILALL ) THEN ILCOMP = .TRUE. ELSE ILCOMP = SELECT( JE ) END IF IF( ILCOMP ) THEN IEIG = IEIG + 1 * IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * DO 50 JR = 1, N VL( JR, IEIG ) = CZERO 50 CONTINUE VL( IEIG, IEIG ) = CONE GO TO 140 END IF * * Non-singular eigenvalue: * Compute coefficients a and b in * H * y ( a A - b B ) = 0 * TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) SALPHA = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * * Scale to avoid underflow * LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. $ SMALL * SCALE = ONE IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), $ ABS1( BCOEFF ) ) ) ) IF( LSA ) THEN ACOEFF = ASCALE*( SCALE*SBETA ) ELSE ACOEFF = SCALE*ACOEFF END IF IF( LSB ) THEN BCOEFF = BSCALE*( SCALE*SALPHA ) ELSE BCOEFF = SCALE*BCOEFF END IF END IF * ACOEFA = ABS( ACOEFF ) BCOEFA = ABS1( BCOEFF ) XMAX = ONE DO 60 JR = 1, N WORK( JR ) = CZERO 60 CONTINUE WORK( JE ) = CONE DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * H * Triangular solve of (a A - b B) y = 0 * * H * (rowwise in (a A - b B) , or columnwise in a A - b B) * DO 100 J = JE + 1, N * * Compute * j-1 * SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * (Scale if necessary) * TEMP = ONE / XMAX IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM* $ TEMP ) THEN DO 70 JR = JE, J - 1 WORK( JR ) = TEMP*WORK( JR ) 70 CONTINUE XMAX = ONE END IF SUMA = CZERO SUMB = CZERO * DO 80 JR = JE, J - 1 SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR ) SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB * * Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) * * with scaling and perturbation of the denominator * D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * IF( ABS1( D ).LT.ONE ) THEN IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN TEMP = ONE / ABS1( SUM ) DO 90 JR = JE, J - 1 WORK( JR ) = TEMP*WORK( JR ) 90 CONTINUE XMAX = TEMP*XMAX SUM = TEMP*SUM END IF END IF WORK( J ) = ZLADIV( -SUM, D ) XMAX = MAX( XMAX, ABS1( WORK( J ) ) ) 100 CONTINUE * * Back transform eigenvector if HOWMNY='B'. * IF( ILBACK ) THEN CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL, $ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 ) ISRC = 2 IBEG = 1 ELSE ISRC = 1 IBEG = JE END IF * * Copy and scale eigenvector into column of VL * XMAX = ZERO DO 110 JR = IBEG, N XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) 110 CONTINUE * IF( XMAX.GT.SAFMIN ) THEN TEMP = ONE / XMAX DO 120 JR = IBEG, N VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) 120 CONTINUE ELSE IBEG = N + 1 END IF * DO 130 JR = 1, IBEG - 1 VL( JR, IEIG ) = CZERO 130 CONTINUE * END IF 140 CONTINUE END IF * * Right eigenvectors * IF( COMPR ) THEN IEIG = IM + 1 * * Main loop over eigenvalues * DO 250 JE = N, 1, -1 IF( ILALL ) THEN ILCOMP = .TRUE. ELSE ILCOMP = SELECT( JE ) END IF IF( ILCOMP ) THEN IEIG = IEIG - 1 * IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * DO 150 JR = 1, N VR( JR, IEIG ) = CZERO 150 CONTINUE VR( IEIG, IEIG ) = CONE GO TO 250 END IF * * Non-singular eigenvalue: * Compute coefficients a and b in * * ( a A - b B ) x = 0 * TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) SALPHA = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * * Scale to avoid underflow * LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. $ SMALL * SCALE = ONE IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), $ ABS1( BCOEFF ) ) ) ) IF( LSA ) THEN ACOEFF = ASCALE*( SCALE*SBETA ) ELSE ACOEFF = SCALE*ACOEFF END IF IF( LSB ) THEN BCOEFF = BSCALE*( SCALE*SALPHA ) ELSE BCOEFF = SCALE*BCOEFF END IF END IF * ACOEFA = ABS( ACOEFF ) BCOEFA = ABS1( BCOEFF ) XMAX = ONE DO 160 JR = 1, N WORK( JR ) = CZERO 160 CONTINUE WORK( JE ) = CONE DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * Triangular solve of (a A - b B) x = 0 (columnwise) * * WORK(1:j-1) contains sums w, * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * DO 210 J = JE - 1, 1, -1 * * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * IF( ABS1( D ).LT.ONE ) THEN IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN TEMP = ONE / ABS1( WORK( J ) ) DO 180 JR = 1, JE WORK( JR ) = TEMP*WORK( JR ) 180 CONTINUE END IF END IF * WORK( J ) = ZLADIV( -WORK( J ), D ) * IF( J.GT.1 ) THEN * * w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE. $ BIGNUM*TEMP ) THEN DO 190 JR = 1, JE WORK( JR ) = TEMP*WORK( JR ) 190 CONTINUE END IF END IF * CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - $ CB*P( JR, J ) 200 CONTINUE END IF 210 CONTINUE * * Back transform eigenvector if HOWMNY='B'. * IF( ILBACK ) THEN CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1, $ CZERO, WORK( N+1 ), 1 ) ISRC = 2 IEND = N ELSE ISRC = 1 IEND = JE END IF * * Copy and scale eigenvector into column of VR * XMAX = ZERO DO 220 JR = 1, IEND XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) 220 CONTINUE * IF( XMAX.GT.SAFMIN ) THEN TEMP = ONE / XMAX DO 230 JR = 1, IEND VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) 230 CONTINUE ELSE IEND = 0 END IF * DO 240 JR = IEND + 1, N VR( JR, IEIG ) = CZERO 240 CONTINUE * END IF 250 CONTINUE END IF * RETURN * * End of ZTGEVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztgex2.f000066400000000000000000000263441522610125300262060ustar00rootroot00000000000000*> \brief \b ZTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary equivalence transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTGEX2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) *> in an upper triangular matrix pair (A, B) by an unitary equivalence *> transformation. *> *> (A, B) must be in generalized Schur canonical form, that is, A and *> B are both upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H *> Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 arrays, dimensions (LDA,N) *> On entry, the matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \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 arrays, dimensions (LDB,N) *> On entry, the matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDZ,N) *> If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, *> the updated matrix Q. *> Not referenced if WANTQ = .FALSE.. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,N) *> If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, *> the updated matrix Z. *> Not referenced if WANTZ = .FALSE.. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index to the first block (A11, B11). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEauxiliary * *> \par Further Details: * ===================== *> *> In the current code both weak and strong stability tests are *> performed. The user can omit the strong stability test by changing *> the internal logical parameter WANDS to .FALSE.. See ref. [2] for *> details. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \n *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, Report UMINF-94.04, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, 1994. Also as LAPACK Working Note 87. To appear in *> Numerical Algorithms, 1996. *> * ===================================================================== SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, INFO ) * * -- LAPACK auxiliary routine (version 3.7.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 WANTQ, WANTZ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION TWENTY PARAMETER ( TWENTY = 2.0D+1 ) INTEGER LDST PARAMETER ( LDST = 2 ) LOGICAL WANDS PARAMETER ( WANDS = .TRUE. ) * .. * .. Local Scalars .. LOGICAL DTRONG, WEAK INTEGER I, M DOUBLE PRECISION CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM, $ THRESH, WS COMPLEX*16 CDUM, F, G, SQ, SZ * .. * .. Local Arrays .. COMPLEX*16 S( LDST, LDST ), T( LDST, LDST ), WORK( 8 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL ZLACPY, ZLARTG, ZLASSQ, ZROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.1 ) $ RETURN * M = LDST WEAK = .FALSE. DTRONG = .FALSE. * * Make a local copy of selected block in (A, B) * CALL ZLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) CALL ZLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) * * Compute the threshold for testing the acceptance of swapping. * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS SCALE = DBLE( CZERO ) SUM = DBLE( CONE ) CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M ) CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) SA = SCALE*SQRT( SUM ) * * THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * on 04/01/10. * "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by * Jim Demmel and Guillaume Revy. See forum post 1783. * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * * Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks * using Givens rotations and perform the swap tentatively. * F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) SA = ABS( S( 2, 2 ) ) SB = ABS( T( 2, 2 ) ) CALL ZLARTG( G, F, CZ, SZ, CDUM ) SZ = -SZ CALL ZROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, DCONJG( SZ ) ) CALL ZROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, DCONJG( SZ ) ) IF( SA.GE.SB ) THEN CALL ZLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM ) ELSE CALL ZLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM ) END IF CALL ZROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ ) CALL ZROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ ) * * Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) * WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) WEAK = WS.LE.THRESH IF( .NOT.WEAK ) $ GO TO 20 * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL**H*S*QR, B-QL**H*T*QR)) <= O(EPS*F-norm((A, B))) * CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M ) CALL ZROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -DCONJG( SZ ) ) CALL ZROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ, -DCONJG( SZ ) ) CALL ZROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ ) CALL ZROT( 2, WORK( 5 ), 2, WORK( 6 ), 2, CQ, -SQ ) DO 10 I = 1, 2 WORK( I ) = WORK( I ) - A( J1+I-1, J1 ) WORK( I+2 ) = WORK( I+2 ) - A( J1+I-1, J1+1 ) WORK( I+4 ) = WORK( I+4 ) - B( J1+I-1, J1 ) WORK( I+6 ) = WORK( I+6 ) - B( J1+I-1, J1+1 ) 10 CONTINUE SCALE = DBLE( CZERO ) SUM = DBLE( CONE ) CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) SS = SCALE*SQRT( SUM ) DTRONG = SS.LE.THRESH IF( .NOT.DTRONG ) $ GO TO 20 END IF * * If the swap is accepted ("weakly" and "strongly"), apply the * equivalence transformations to the original matrix pair (A,B) * CALL ZROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ, $ DCONJG( SZ ) ) CALL ZROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ, $ DCONJG( SZ ) ) CALL ZROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ, SQ ) CALL ZROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, CQ, SQ ) * * Set N1 by N2 (2,1) blocks to 0 * A( J1+1, J1 ) = CZERO B( J1+1, J1 ) = CZERO * * Accumulate transformations into Q and Z if requested. * IF( WANTZ ) $ CALL ZROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ, $ DCONJG( SZ ) ) IF( WANTQ ) $ CALL ZROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ, $ DCONJG( SQ ) ) * * Exit with INFO = 0 if swap was successfully performed. * RETURN * * Exit with INFO = 1 if swap was rejected. * 20 CONTINUE INFO = 1 RETURN * * End of ZTGEX2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztgexc.f000066400000000000000000000213401522610125300262560ustar00rootroot00000000000000*> \brief \b ZTGEXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTGEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTGEXC reorders the generalized Schur decomposition of a complex *> matrix pair (A,B), using an unitary equivalence transformation *> (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with *> row index IFST is moved to row ILST. *> *> (A, B) must be in generalized Schur canonical form, that is, A and *> B are both upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H *> Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \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 upper triangular matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \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 upper triangular matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDZ,N) *> On entry, if WANTQ = .TRUE., the unitary matrix Q. *> On exit, the updated matrix Q. *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., the unitary matrix Z. *> On exit, the updated matrix Z. *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> Specify the reordering of the diagonal blocks of (A, B). *> The block with row index IFST is moved to row ILST, by a *> sequence of swapping between adjacent blocks. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit. *> <0: if INFO = -i, the i-th argument had an illegal value. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. (A, B) may have been partially reordered, *> and ILST points to the first row of the current *> position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16GEcomputational * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \n *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, Report *> UMINF - 94.04, Department of Computing Science, Umea University, *> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. *> To appear in Numerical Algorithms, 1996. *> \n *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> * ===================================================================== SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, 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 .. LOGICAL WANTQ, WANTZ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER HERE * .. * .. External Subroutines .. EXTERNAL XERBLA, ZTGEX2 * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input arguments. INFO = 0 IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -12 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGEXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * HERE = IFST * 10 CONTINUE * * Swap with next one below * CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, $ HERE, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 IF( HERE.LT.ILST ) $ GO TO 10 HERE = HERE - 1 ELSE HERE = IFST - 1 * 20 CONTINUE * * Swap with next one above * CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, $ HERE, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 IF( HERE.GE.ILST ) $ GO TO 20 HERE = HERE + 1 END IF ILST = HERE RETURN * * End of ZTGEXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztgsen.f000066400000000000000000000642311522610125300262720ustar00rootroot00000000000000*> \brief \b ZTGSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTGSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ M, N * DOUBLE PRECISION PL, PR * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION DIF( * ) * COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTGSEN reorders the generalized Schur decomposition of a complex *> matrix pair (A, B) (in terms of an unitary equivalence trans- *> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues *> appears in the leading diagonal blocks of the pair (A,B). The leading *> columns of Q and Z form unitary bases of the corresponding left and *> right eigenspaces (deflating subspaces). (A, B) must be in *> generalized Schur canonical form, that is, A and B are both upper *> triangular. *> *> ZTGSEN also computes the generalized eigenvalues *> *> w(j)= ALPHA(j) / BETA(j) *> *> of the reordered matrix pair (A, B). *> *> Optionally, the routine computes estimates of reciprocal condition *> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), *> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) *> between the matrix pairs (A11, B11) and (A22,B22) that correspond to *> the selected cluster and the eigenvalues outside the cluster, resp., *> and norms of "projections" onto left and right eigenspaces w.r.t. *> the selected cluster in the (1,1)-block. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is integer *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (PL and PR) or the deflating subspaces *> (Difu and Difl): *> =0: Only reorder w.r.t. SELECT. No extras. *> =1: Reciprocal of norms of "projections" onto left and right *> eigenspaces w.r.t. the selected cluster (PL and PR). *> =2: Upper bounds on Difu and Difl. F-norm-based estimate *> (DIF(1:2)). *> =3: Estimate of Difu and Difl. 1-norm-based estimate *> (DIF(1:2)). *> About 5 times as expensive as IJOB = 2. *> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic *> version to get it all. *> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) *> \endverbatim *> *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select an eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. *> \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 upper triangular matrix A, in generalized *> Schur canonical form. *> On exit, A is overwritten by the reordered matrix A. *> \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 upper triangular matrix B, in generalized *> Schur canonical form. *> On exit, B is overwritten by the reordered matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is COMPLEX*16 array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is COMPLEX*16 array, dimension (N) *> *> The diagonal elements of A and B, respectively, *> when the pair (A,B) has been reduced to generalized Schur *> form. ALPHA(i)/BETA(i) i=1,...,N are the generalized *> eigenvalues. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. *> On exit, Q has been postmultiplied by the left unitary *> transformation matrix which reorder (A, B); The leading M *> columns of Q form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is COMPLEX*16 array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. *> On exit, Z has been postmultiplied by the left unitary *> transformation matrix which reorder (A, B); The leading M *> columns of Z form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified pair of left and right *> eigenspaces, (deflating subspaces) 0 <= M <= N. *> \endverbatim *> *> \param[out] PL *> \verbatim *> PL is DOUBLE PRECISION *> \endverbatim *> *> \param[out] PR *> \verbatim *> PR is DOUBLE PRECISION *> *> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the *> reciprocal of the norm of "projections" onto left and right *> eigenspace with respect to the selected cluster. *> 0 < PL, PR <= 1. *> If M = 0 or M = N, PL = PR = 1. *> If IJOB = 0, 2 or 3 PL, PR are not referenced. *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION array, dimension (2). *> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. *> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on *> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based *> estimates of Difu and Difl, computed using reversed *> communication with ZLACN2. *> If M = 0 or N, DIF(1:2) = F-norm([A, B]). *> If IJOB = 0 or 1, DIF is not referenced. *> \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. LWORK >= 1 *> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) *> If IJOB = 3 or 5, LWORK >= 4*M*(N-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] 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. LIWORK >= 1. *> If IJOB = 1, 2 or 4, LIWORK >= N+2; *> If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); *> *> 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. *> =1: Reordering of (A, B) failed because the transformed *> matrix pair (A, B) would be too far from generalized *> Schur form; the problem is very ill-conditioned. *> (A, B) may have been partially reordered. *> If requested, 0 is returned in DIF(*), PL and PR. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup complex16OTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> ZTGSEN first collects the selected eigenvalues by computing unitary *> U and W that move them to the top left corner of (A, B). In other *> words, the selected eigenvalues are the eigenvalues of (A11, B11) in *> *> U**H*(A, B)*W = (A11 A12) (B11 B12) n1 *> ( 0 A22),( 0 B22) n2 *> n1 n2 n1 n2 *> *> where N = n1+n2 and U**H means the conjugate transpose of U. The first *> n1 columns of U and W span the specified pair of left and right *> eigenspaces (deflating subspaces) of (A, B). *> *> If (A, B) has been obtained from the generalized real Schur *> decomposition of a matrix pair (C, D) = Q*(A, B)*Z**H, then the *> reordered generalized Schur form of (C, D) is given by *> *> (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H, *> *> and the first n1 columns of Q*U and Z*W span the corresponding *> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). *> *> Note that if the selected eigenvalue is sufficiently ill-conditioned, *> then its value may differ significantly from its value before *> reordering. *> *> The reciprocal condition numbers of the left and right eigenspaces *> spanned by the first n1 columns of U and W (or Q*U and Z*W) may *> be returned in DIF(1:2), corresponding to Difu and Difl, resp. *> *> The Difu and Difl are defined as: *> *> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) *> and *> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], *> *> where sigma-min(Zu) is the smallest singular value of the *> (2*n1*n2)-by-(2*n1*n2) matrix *> *> Zu = [ kron(In2, A11) -kron(A22**H, In1) ] *> [ kron(In2, B11) -kron(B22**H, In1) ]. *> *> Here, Inx is the identity matrix of size nx and A22**H is the *> conjugate transpose of A22. kron(X, Y) is the Kronecker product between *> the matrices X and Y. *> *> When DIF(2) is small, small changes in (A, B) can cause large changes *> in the deflating subspace. An approximate (asymptotic) bound on the *> maximum angular error in the computed deflating subspaces is *> *> EPS * norm((A, B)) / DIF(2), *> *> where EPS is the machine precision. *> *> The reciprocal norm of the projectors on the left and right *> eigenspaces associated with (A11, B11) may be returned in PL and PR. *> They are computed as follows. First we compute L and R so that *> P*(A, B)*Q is block diagonal, where *> *> P = ( I -L ) n1 Q = ( I R ) n1 *> ( 0 I ) n2 and ( 0 I ) n2 *> n1 n2 n1 n2 *> *> and (L, R) is the solution to the generalized Sylvester equation *> *> A11*R - L*A22 = -A12 *> B11*R - L*B22 = -B12 *> *> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). *> An approximate (asymptotic) bound on the average absolute error of *> the selected eigenvalues is *> *> EPS * norm((A, B)) / PL. *> *> There are also global error bounds which valid for perturbations up *> to a certain restriction: A lower bound (x) on the smallest *> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and *> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), *> (i.e. (A + E, B + F), is *> *> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). *> *> An approximate bound on x can be computed from DIF(1:2), PL and PR. *> *> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed *> (L', R') and unperturbed (L, R) left and right deflating subspaces *> associated with the selected cluster in the (1,1)-blocks can be *> bounded as *> *> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) *> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) *> *> See LAPACK User's Guide section 4.11 or the following references *> for more information. *> *> Note that if the default method for computing the Frobenius-norm- *> based estimate DIF is not wanted (see ZLATDF), then the parameter *> IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF *> (IJOB = 2 will be used)). See ZTGSYL for more details. *> \endverbatim * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \n *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, Report *> UMINF - 94.04, Department of Computing Science, Umea University, *> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. *> To appear in Numerical Algorithms, 1996. *> \n *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> * ===================================================================== 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.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 .. LOGICAL WANTQ, WANTZ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, $ M, N DOUBLE PRECISION PL, PR * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION DIF( * ) COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IDIFJB PARAMETER ( IDIFJB = 3 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2, $ N1, N2 DOUBLE PRECISION DSCALE, DSUM, RDSCAL, SAFMIN COMPLEX*16 TEMP1, TEMP2 * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC, $ ZTGSYL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, DCONJG, MAX, SQRT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Executable Statements .. * * Decode and test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -13 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGSEN', -INFO ) RETURN END IF * IERR = 0 * WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 WANTD = WANTD1 .OR. WANTD2 * * Set M to the dimension of the specified pair of deflating * 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 ) IF( K.LT.N ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE IF( SELECT( N ) ) $ 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 ) ) LIWMIN = MAX( 1, N+2 ) ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN LWMIN = MAX( 1, 4*M*( N-M ) ) LIWMIN = MAX( 1, 2*M*( N-M ), N+2 ) ELSE LWMIN = 1 LIWMIN = 1 END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -21 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -23 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTP ) THEN PL = ONE PR = ONE END IF IF( WANTD ) THEN DSCALE = ZERO DSUM = ONE DO 20 I = 1, N CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 20 CONTINUE DIF( 1 ) = DSCALE*SQRT( DSUM ) DIF( 2 ) = DIF( 1 ) END IF GO TO 70 END IF * * Get machine constant * SAFMIN = DLAMCH( 'S' ) * * Collect the selected blocks at the top-left corner of (A, B). * KS = 0 DO 30 K = 1, N SWAP = SELECT( K ) IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. Compute unitary Q * and Z that will swap adjacent diagonal blocks in (A, B). * IF( K.NE.KS ) $ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, K, KS, IERR ) * IF( IERR.GT.0 ) THEN * * Swap is rejected: exit. * INFO = 1 IF( WANTP ) THEN PL = ZERO PR = ZERO END IF IF( WANTD ) THEN DIF( 1 ) = ZERO DIF( 2 ) = ZERO END IF GO TO 70 END IF END IF 30 CONTINUE IF( WANTP ) THEN * * Solve generalized Sylvester equation for R and L: * A11 * R - L * A22 = A12 * B11 * R - L * B22 = B12 * N1 = M N2 = N - M I = N1 + 1 CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), $ N1 ) IJB = 0 CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Estimate the reciprocal of norms of "projections" onto * left and right eigenspaces * RDSCAL = ZERO DSUM = ONE CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) PL = RDSCAL*SQRT( DSUM ) IF( PL.EQ.ZERO ) THEN PL = ONE ELSE PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) END IF RDSCAL = ZERO DSUM = ONE CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) PR = RDSCAL*SQRT( DSUM ) IF( PR.EQ.ZERO ) THEN PR = ONE ELSE PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) END IF END IF IF( WANTD ) THEN * * Compute estimates Difu and Difl. * IF( WANTD1 ) THEN N1 = M N2 = N - M I = N1 + 1 IJB = IDIFJB * * Frobenius norm-based Difu estimate. * CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), $ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Frobenius norm-based Difl estimate. * CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), $ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) ELSE * * Compute 1-norm-based estimates of Difu and Difl using * reversed communication with ZLACN2. In each step a * generalized Sylvester equation or a transposed variant * is solved. * KASE = 0 N1 = M N2 = N - M I = N1 + 1 IJB = 0 MN2 = 2*N1*N2 * * 1-norm-based estimate of Difu. * 40 CONTINUE CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation * CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 40 END IF DIF( 1 ) = DSCALE / DIF( 1 ) * * 1-norm-based estimate of Difl. * 50 CONTINUE CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation * CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 50 END IF DIF( 2 ) = DSCALE / DIF( 2 ) END IF END IF * * If B(K,K) is complex, make it real and positive (normalization * of the generalized Schur form) and Store the generalized * eigenvalues of reordered pair (A, B) * DO 60 K = 1, N DSCALE = ABS( B( K, K ) ) IF( DSCALE.GT.SAFMIN ) THEN TEMP1 = DCONJG( B( K, K ) / DSCALE ) TEMP2 = B( K, K ) / DSCALE B( K, K ) = DSCALE CALL ZSCAL( N-K, TEMP1, B( K, K+1 ), LDB ) CALL ZSCAL( N-K+1, TEMP1, A( K, K ), LDA ) IF( WANTQ ) $ CALL ZSCAL( N, TEMP2, Q( 1, K ), 1 ) ELSE B( K, K ) = DCMPLX( ZERO, ZERO ) END IF * ALPHA( K ) = A( K, K ) BETA( K ) = B( K, K ) * 60 CONTINUE * 70 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of ZTGSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztgsy2.f000066400000000000000000000355231522610125300262240ustar00rootroot00000000000000*> \brief \b ZTGSY2 solves the generalized Sylvester equation (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTGSY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 * DOUBLE PRECISION RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTGSY2 solves the generalized Sylvester equation *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, *> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, *> N-by-N and M-by-N, respectively. A, B, D and E are upper triangular *> (i.e., (A,D) and (B,E) in generalized Schur form). *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output *> scaling factor chosen to avoid overflow. *> *> In matrix notation solving equation (1) corresponds to solve *> Zx = scale * b, where Z is defined as *> *> Z = [ kron(In, A) -kron(B**H, Im) ] (2) *> [ kron(In, D) -kron(E**H, Im) ], *> *> Ik is the identity matrix of size k and X**H is the conjuguate transpose of X. *> kron(X, Y) is the Kronecker product between the matrices X and Y. *> *> If TRANS = 'C', y in the conjugate transposed system Z**H*y = scale*b *> is solved for, which is equivalent to solve for R and L in *> *> A**H * R + D**H * L = scale * C (3) *> R * B**H + L * E**H = scale * -F *> *> This case is used to compute an estimate of Dif[(A, D), (B, E)] = *> = sigma_min(Z) using reverse communicaton with ZLACON. *> *> ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL *> of an upper bound on the separation between to matrix pairs. Then *> the input (A, D), (B, E) are sub-pencils of two matrix pairs in *> ZTGSYL. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T': solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (look ahead strategy is used). *> =2: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (DGECON on sub-systems is used.) *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the order of A and D, and the row *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of B and E, and the column *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, M) *> On entry, A contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the matrix A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB, N) *> On entry, B contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is COMPLEX*16 array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1). *> On exit, if IJOB = 0, C has been overwritten by the solution *> R. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the matrix C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is COMPLEX*16 array, dimension (LDD, M) *> On entry, D contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the matrix D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is COMPLEX*16 array, dimension (LDE, N) *> On entry, E contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the matrix E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is COMPLEX*16 array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1). *> On exit, if IJOB = 0, F has been overwritten by the solution *> L. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the matrix F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions *> R and L (C and F on entry) will hold the solutions to a *> slightly perturbed system but the input matrices A, B, D and *> E have not been changed. If SCALE = 0, R and L will hold the *> solutions to the homogeneous system with C = F = 0. *> Normally, SCALE = 1. *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is DOUBLE PRECISION *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by ZTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when ZTGSY2 is called by *> ZTGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is DOUBLE PRECISION *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when ZTGSY2 is called by *> ZTGSYL. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, if INFO is set to *> =0: Successful exit *> <0: If INFO = -i, input argument number i is illegal. *> >0: The matrix pairs (A, D) and (B, E) have common or very *> close eigenvalues. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16SYauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N DOUBLE PRECISION RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE INTEGER LDZ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, LDZ = 2 ) * .. * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, IERR, J, K DOUBLE PRECISION SCALOC COMPLEX*16 ALPHA * .. * .. Local Arrays .. INTEGER IPIV( LDZ ), JPIV( LDZ ) COMPLEX*16 RHS( LDZ ), Z( LDZ, LDZ ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZGESC2, ZGETC2, ZLATDF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, DCONJG, MAX * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 IERR = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGSY2', -INFO ) RETURN END IF * IF( NOTRAN ) THEN * * Solve (I, J) - system * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = M, M - 1, ..., 1; J = 1, 2, ..., N * SCALE = ONE SCALOC = ONE DO 30 J = 1, N DO 20 I = M, 1, -1 * * Build 2 by 2 system * Z( 1, 1 ) = A( I, I ) Z( 2, 1 ) = D( I, I ) Z( 1, 2 ) = -B( J, J ) Z( 2, 2 ) = -E( J, J ) * * Set up right hand side(s) * RHS( 1 ) = C( I, J ) RHS( 2 ) = F( I, J ) * * Solve Z * x = RHS * CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 10 K = 1, N CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), $ C( 1, K ), 1 ) CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), $ F( 1, K ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL ZLATDF( IJOB, LDZ, Z, LDZ, RHS, RDSUM, RDSCAL, $ IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( I, J ) = RHS( 1 ) F( I, J ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining equation. * IF( I.GT.1 ) THEN ALPHA = -RHS( 1 ) CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ), 1 ) CALL ZAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ), 1 ) END IF IF( J.LT.N ) THEN CALL ZAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB, $ C( I, J+1 ), LDC ) CALL ZAXPY( N-J, RHS( 2 ), E( J, J+1 ), LDE, $ F( I, J+1 ), LDF ) END IF * 20 CONTINUE 30 CONTINUE ELSE * * Solve transposed (I, J) - system: * A(I, I)**H * R(I, J) + D(I, I)**H * L(J, J) = C(I, J) * R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1, 2, ..., M, J = N, N - 1, ..., 1 * SCALE = ONE SCALOC = ONE DO 80 I = 1, M DO 70 J = N, 1, -1 * * Build 2 by 2 system Z**H * Z( 1, 1 ) = DCONJG( A( I, I ) ) Z( 2, 1 ) = -DCONJG( B( J, J ) ) Z( 1, 2 ) = DCONJG( D( I, I ) ) Z( 2, 2 ) = -DCONJG( E( J, J ) ) * * * Set up right hand side(s) * RHS( 1 ) = C( I, J ) RHS( 2 ) = F( I, J ) * * Solve Z**H * x = RHS * CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 40 K = 1, N CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( I, J ) = RHS( 1 ) F( I, J ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining equation. * DO 50 K = 1, J - 1 F( I, K ) = F( I, K ) + RHS( 1 )*DCONJG( B( K, J ) ) + $ RHS( 2 )*DCONJG( E( K, J ) ) 50 CONTINUE DO 60 K = I + 1, M C( K, J ) = C( K, J ) - DCONJG( A( I, K ) )*RHS( 1 ) - $ DCONJG( D( I, K ) )*RHS( 2 ) 60 CONTINUE * 70 CONTINUE 80 CONTINUE END IF RETURN * * End of ZTGSY2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztgsyl.f000066400000000000000000000564331522610125300263210ustar00rootroot00000000000000*> \brief \b ZTGSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTGSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * $ LWORK, M, N * DOUBLE PRECISION DIF, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTGSYL solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> where R and L are unknown m-by-n matrices, (A, D), (B, E) and *> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, *> respectively, with complex entries. A, B, D and E are upper *> triangular (i.e., (A,D) and (B,E) in generalized Schur form). *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 *> is an output scaling factor chosen to avoid overflow. *> *> In matrix notation (1) is equivalent to solve Zx = scale*b, where Z *> is defined as *> *> Z = [ kron(In, A) -kron(B**H, Im) ] (2) *> [ kron(In, D) -kron(E**H, Im) ], *> *> Here Ix is the identity matrix of size x and X**H is the conjugate *> transpose of X. Kron(X, Y) is the Kronecker product between the *> matrices X and Y. *> *> If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b *> is solved for, which is equivalent to solve for R and L in *> *> A**H * R + D**H * L = scale * C (3) *> R * B**H + L * E**H = scale * -F *> *> This case (TRANS = 'C') is used to compute an one-norm-based estimate *> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) *> and (B,E), using ZLACON. *> *> If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of *> Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the *> reciprocal of the smallest singular value of Z. *> *> This is a level-3 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': solve the generalized sylvester equation (1). *> = 'C': solve the "conjugate transposed" system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: The functionality of 0 and 3. *> =2: The functionality of 0 and 4. *> =3: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (look ahead strategy is used). *> =4: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (ZGECON on sub-systems is used). *> Not referenced if TRANS = 'C'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrices A and D, and the row dimension of *> the matrices C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices B and E, and the column dimension *> of the matrices C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, M) *> The upper triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB, N) *> The upper triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is COMPLEX*16 array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, C has been overwritten by *> the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is COMPLEX*16 array, dimension (LDD, M) *> The upper triangular matrix D. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the array D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is COMPLEX*16 array, dimension (LDE, N) *> The upper triangular matrix E. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the array E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is COMPLEX*16 array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, F has been overwritten by *> the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION *> On exit DIF is the reciprocal of a lower bound of the *> reciprocal of the Dif-function, i.e. DIF is an upper bound of *> Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2). *> IF IJOB = 0 or TRANS = 'C', DIF is not referenced. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit SCALE is the scaling factor in (1) or (3). *> If 0 < SCALE < 1, C and F hold the solutions R and L, resp., *> to a slightly perturbed system but the input matrices A, B, *> D and E have not been changed. If SCALE = 0, R and L will *> hold the solutions to the homogenious system with C = F = 0. *> \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. LWORK > = 1. *> If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*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] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+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: (A, D) and (B, E) have common or very close *> eigenvalues. *> \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: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, *> No 1, 1996. *> \n *> [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester *> Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. *> Appl., 15(4):1045-1060, 1994. *> \n *> [3] B. Kagstrom and L. Westin, Generalized Schur Methods with *> Condition Estimators for Solving the Generalized Sylvester *> Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, *> July 1989, pp 745-751. *> * ===================================================================== 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.7.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 IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, $ LWORK, M, N DOUBLE PRECISION DIF, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ), $ WORK( * ) * .. * * ===================================================================== * Replaced various illegal calls to CCOPY by calls to CLASET. * Sven Hammarling, 1/5/02. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = (0.0D+0, 0.0D+0) ) * .. * .. Local Scalars .. LOGICAL LQUERY, NOTRAN INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, $ LINFO, LWMIN, MB, NB, P, PQ, Q DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMM, ZLACPY, ZLASET, ZSCAL, ZTGSY2 * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF * IF( INFO.EQ.0 ) THEN IF( NOTRAN ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN LWMIN = MAX( 1, 2*M*N ) ELSE LWMIN = 1 END IF ELSE LWMIN = 1 END IF WORK( 1 ) = LWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGSYL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN SCALE = 1 IF( NOTRAN ) THEN IF( IJOB.NE.0 ) THEN DIF = 0 END IF END IF RETURN END IF * * Determine optimal block sizes MB and NB * MB = ILAENV( 2, 'ZTGSYL', TRANS, M, N, -1, -1 ) NB = ILAENV( 5, 'ZTGSYL', TRANS, M, N, -1, -1 ) * ISOLVE = 1 IFUNC = 0 IF( NOTRAN ) THEN IF( IJOB.GE.3 ) THEN IFUNC = IJOB - 2 CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC ) CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF ) ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN ISOLVE = 2 END IF END IF * IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) $ THEN * * Use unblocked Level 2 solver * DO 30 IROUND = 1, ISOLVE * SCALE = ONE DSCALE = ZERO DSUM = ONE PQ = M*N CALL ZTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, $ INFO ) IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL ZLACPY( 'F', M, N, C, LDC, WORK, M ) CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC ) CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL ZLACPY( 'F', M, N, WORK, M, C, LDC ) CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 30 CONTINUE * RETURN * END IF * * Determine block structure of A * P = 0 I = 1 40 CONTINUE IF( I.GT.M ) $ GO TO 50 P = P + 1 IWORK( P ) = I I = I + MB IF( I.GE.M ) $ GO TO 50 GO TO 40 50 CONTINUE IWORK( P+1 ) = M + 1 IF( IWORK( P ).EQ.IWORK( P+1 ) ) $ P = P - 1 * * Determine block structure of B * Q = P + 1 J = 1 60 CONTINUE IF( J.GT.N ) $ GO TO 70 * Q = Q + 1 IWORK( Q ) = J J = J + NB IF( J.GE.N ) $ GO TO 70 GO TO 60 * 70 CONTINUE IWORK( Q+1 ) = N + 1 IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) $ Q = Q - 1 * IF( NOTRAN ) THEN DO 150 IROUND = 1, ISOLVE * * Solve (I, J) - subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1, ..., 1; J = 1, 2, ..., Q * PQ = 0 SCALE = ONE DSCALE = ZERO DSUM = ONE DO 130 J = P + 2, Q JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 120 I = P, 1, -1 IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO PQ = PQ + MB*NB IF( SCALOC.NE.ONE ) THEN DO 80 K = 1, JS - 1 CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), $ C( 1, K ), 1 ) CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), $ F( 1, K ), 1 ) 80 CONTINUE DO 90 K = JS, JE CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), $ C( 1, K ), 1 ) CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), $ F( 1, K ), 1 ) 90 CONTINUE DO 100 K = JS, JE CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), $ C( IE+1, K ), 1 ) CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), $ F( IE+1, K ), 1 ) 100 CONTINUE DO 110 K = JE + 1, N CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), $ C( 1, K ), 1 ) CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), $ F( 1, K ), 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I,J) and L(I,J) into remaining equation. * IF( I.GT.1 ) THEN CALL ZGEMM( 'N', 'N', IS-1, NB, MB, $ DCMPLX( -ONE, ZERO ), A( 1, IS ), LDA, $ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ), $ C( 1, JS ), LDC ) CALL ZGEMM( 'N', 'N', IS-1, NB, MB, $ DCMPLX( -ONE, ZERO ), D( 1, IS ), LDD, $ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ), $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL ZGEMM( 'N', 'N', MB, N-JE, NB, $ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF, $ B( JS, JE+1 ), LDB, $ DCMPLX( ONE, ZERO ), C( IS, JE+1 ), $ LDC ) CALL ZGEMM( 'N', 'N', MB, N-JE, NB, $ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF, $ E( JS, JE+1 ), LDE, $ DCMPLX( ONE, ZERO ), F( IS, JE+1 ), $ LDF ) END IF 120 CONTINUE 130 CONTINUE IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL ZLACPY( 'F', M, N, C, LDC, WORK, M ) CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC ) CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL ZLACPY( 'F', M, N, WORK, M, C, LDC ) CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 150 CONTINUE ELSE * * Solve transposed (I, J)-subsystem * A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J) * R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1,2,..., P; J = Q, Q-1,..., 1 * SCALE = ONE DO 210 I = 1, P IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 DO 200 J = Q, P + 2, -1 JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO IF( SCALOC.NE.ONE ) THEN DO 160 K = 1, JS - 1 CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 160 CONTINUE DO 170 K = JS, JE CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), $ C( 1, K ), 1 ) CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ), $ F( 1, K ), 1 ) 170 CONTINUE DO 180 K = JS, JE CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), $ C( IE+1, K ), 1 ) CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ), $ F( IE+1, K ), 1 ) 180 CONTINUE DO 190 K = JE + 1, N CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ), $ 1 ) CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ), $ 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I,J) and L(I,J) into remaining equation. * IF( J.GT.P+2 ) THEN CALL ZGEMM( 'N', 'C', MB, JS-1, NB, $ DCMPLX( ONE, ZERO ), C( IS, JS ), LDC, $ B( 1, JS ), LDB, DCMPLX( ONE, ZERO ), $ F( IS, 1 ), LDF ) CALL ZGEMM( 'N', 'C', MB, JS-1, NB, $ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF, $ E( 1, JS ), LDE, DCMPLX( ONE, ZERO ), $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL ZGEMM( 'C', 'N', M-IE, NB, MB, $ DCMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA, $ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ), $ C( IE+1, JS ), LDC ) CALL ZGEMM( 'C', 'N', M-IE, NB, MB, $ DCMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD, $ F( IS, JS ), LDF, DCMPLX( ONE, ZERO ), $ C( IE+1, JS ), LDC ) END IF 200 CONTINUE 210 CONTINUE END IF * WORK( 1 ) = LWMIN * RETURN * * End of ZTGSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztplqt.f000066400000000000000000000174601522610125300263200ustar00rootroot00000000000000*> \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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 lower trapezoidal. *> *> The lower trapezoidal matrix B2 consists of the first L columns of a *> M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> [ W ] = [ I ] [ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztplqt2.f000066400000000000000000000223431522610125300263760ustar00rootroot00000000000000*> \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,M) *> 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,M). *> \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 June 2017 * *> \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 M-by-M 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 M-by-M *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ I ][ V ] *> [ I ] <- identity, M-by-M *> [ 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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztpmlqt.f000066400000000000000000000242361522610125300264740ustar00rootroot00000000000000*> \brief \b ZTPMLQT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTPMLQT + 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 *> *> ZTPMLQT 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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**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. *> 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**H*C or C*Q or C*Q**H. 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 June 2017 * *> \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**H * 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**H. *> \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.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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 qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztpmqrt.f000066400000000000000000000243471522610125300265050ustar00rootroot00000000000000*> \brief \b ZTPMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTPMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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 * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**H. *> \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] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CTPQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CTPQRT 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 CTPQRT, stored as a NB-by-K matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \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**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. *> 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**H*C or C*Q or C*Q**H. 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*NB if SIDE = 'L', or M*NB 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 complex16OTHERcomputational * *> \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 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 = '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. *> *> 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**H * 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**H. *> \endverbatim *> * ===================================================================== SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, 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, NB, LDT * .. * .. Array Arguments .. COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), $ WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. 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 LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN LDVQ = MAX( 1, N ) 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( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) 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( 'ZTPMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * DO I = 1, K, NB 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 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 IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB 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 CALL ZTPRFB( 'L', 'N', '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. TRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 ELSE 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, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * END IF * RETURN * * End of ZTPMQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztpqrt.f000066400000000000000000000172631522610125300263270ustar00rootroot00000000000000*> \brief \b ZTPQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTPQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 *> WY representation for Q. *> \endverbatim * * Arguments: * ========== * *> \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, and the order of the *> triangular matrix A. *> N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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 *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (NB*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 complex16OTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 number of blocks is B = ceiling(N/NB), where each *> 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 *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. *> \endverbatim *> * ===================================================================== SUBROUTINE ZTPQRT( M, N, L, NB, 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, NB * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, LB, MB, IINFO * .. * .. External Subroutines .. EXTERNAL ZTPQRT2, 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( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTPQRT', -INFO ) RETURN END IF * * Quick return if possible * 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 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF * 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, $ WORK, IB ) END IF END DO RETURN * * End of ZTPQRT * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztpqrt2.f000066400000000000000000000207561522610125300264120ustar00rootroot00000000000000*> \brief \b ZTPQRT2 computes a QR 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 ZTPQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \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, *> 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 upper 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 upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \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 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 *> *> \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 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,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 complex16OTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ 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 *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ 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. *> *> 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 *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ 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 ] <- (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 (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**H *> *> where W**H is the conjugate transpose of W and T is the upper triangular *> factor of the block reflector. *> \endverbatim *> * ===================================================================== SUBROUTINE ZTPQRT2( 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( ONE = (1.0,0.0), ZERO = (0.0,0.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, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTPQRT2', -INFO ) RETURN END IF * * 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) * P = M-L+MIN( L, I ) CALL ZLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) ) IF( I.LT.N ) THEN * * W(1:N-I) := C(I:M,I+1:N)**H * C(I:M,I) [use W = T(:,N)] * 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, $ 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 )) 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, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO * DO I = 2, N * * T(1:I-1,I) := C(I:M,1:I-1)**H * (alpha * C(I:M,I)) * ALPHA = -T( I, 1 ) DO J = 1, I-1 T( J, I ) = ZERO END DO P = MIN( I-1, L ) MP = MIN( M-L+1, M ) NP = MIN( P+1, N ) * * Triangular part of B2 * DO J = 1, P T( J, I ) = ALPHA*B( M-L+J, I ) END DO CALL ZTRMV( 'U', 'C', 'N', P, B( MP, 1 ), LDB, $ T( 1, I ), 1 ) * * Rectangular part of B2 * 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 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL ZTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO * * End of ZTPQRT2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztprfb.f000066400000000000000000000627161522610125300262750ustar00rootroot00000000000000*> \brief \b ZTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTPRFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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, * ), * $ 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 *> blocks A and B, either from the left or right. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**H from the Left *> = 'R': apply H or H**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'C': apply H**H (Conjugate transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columns *> = 'R': Rows *> \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 order of the matrix T, i.e. the number of elementary *> 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. *> K >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The pentagonal matrix V, which contains the elementary reflectors *> H(1), H(2), ..., H(K). See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= K. *> \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 *> 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. *> 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 *> H*C or H**H*C or C*H or C*H**H. 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, dimension *> (LDWORK,N) if SIDE = 'L', *> (LDWORK,K) if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> 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. * *> \date December 2016 * *> \ingroup complex16OTHERauxiliary * *> \par Further Details: * ===================== *> *> \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, *> 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] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] *> [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 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. *> *> If DIRECT = 'F' and STOREV = 'C': V = [V1] *> [V2] *> - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) *> *> If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] *> *> - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'C': V = [V2] *> [V1] *> - 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. *> *> If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. *> *> If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. *> *> If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. *> \endverbatim *> * ===================================================================== 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.7.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 DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * * ========================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = (1.0,0.0), ZERO = (0.0,0.0) ) * .. * .. Local Scalars .. INTEGER I, J, MP, NP, KP LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZGEMM, ZTRMM * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 .OR. L.LT.0 ) RETURN * IF( LSAME( STOREV, 'C' ) ) THEN COLUMN = .TRUE. ROW = .FALSE. ELSE IF ( LSAME( STOREV, 'R' ) ) THEN COLUMN = .FALSE. ROW = .TRUE. ELSE COLUMN = .FALSE. ROW = .FALSE. END IF * IF( LSAME( SIDE, 'L' ) ) THEN LEFT = .TRUE. RIGHT = .FALSE. ELSE IF( LSAME( SIDE, 'R' ) ) THEN LEFT = .FALSE. RIGHT = .TRUE. ELSE LEFT = .FALSE. RIGHT = .FALSE. END IF * IF( LSAME( DIRECT, 'F' ) ) THEN FORWARD = .TRUE. BACKWARD = .FALSE. ELSE IF( LSAME( DIRECT, 'B' ) ) THEN FORWARD = .FALSE. BACKWARD = .TRUE. ELSE FORWARD = .FALSE. BACKWARD = .FALSE. END IF * * --------------------------------------------------------------------------- * IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (M-by-K) * * Form H C or H**H C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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, $ ONE, WORK, LDWORK ) 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, $ 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, 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 ) CALL ZTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (N-by-K) * * Form C H or C H**H where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - (A + B V) T or A = A - (A + B V) T**H * B = B - (A + B V) T V**H or B = B - (A + B V) T**H V**H * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V, LDV, ONE, WORK, LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL ZGEMM( 'N', 'C', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL ZGEMM( 'N', 'C', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, $ V( NP, KP ), LDV, ONE, B( 1, NP ), LDB ) CALL ZTRMM( 'R', 'U', 'C', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (M-by-K) * [ I ] (K-by-K) * * Form H C or H**H C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO * 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, $ 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 ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * 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, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL ZGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL ZTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (N-by-K) * [ I ] (K-by-K) * * Form C H or C H**H where C = [ B A ] (B is M-by-N, A is M-by-K) * * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - (A + B V) T or A = A - (A + B V) T**H * B = B - (A + B V) T V**H or B = B - (A + B V) T**H V**H * * --------------------------------------------------------------------------- * 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 ) END DO 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, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL ZGEMM( 'N', 'C', M, N-L, K, -ONE, WORK, LDWORK, $ V( NP, 1 ), LDV, ONE, B( 1, NP ), LDB ) CALL ZGEMM( 'N', 'C', M, L, K-L, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL ZTRMM( 'R', 'L', 'C', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**H C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * 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) * * --------------------------------------------------------------------------- * 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', '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, $ ONE, WORK, LDWORK ) CALL ZGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), 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, $ 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( '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, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL ZTRMM( 'L', 'L', 'C', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**H where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - (A + B V**H) T or A = A - (A + B V**H) T**H * B = B - (A + B V**H) T V or B = B - (A + B V**H) T**H V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL ZTRMM( 'R', 'L', 'C', 'N', M, L, ONE, V( 1, NP ), LDV, $ 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, $ V( KP, 1 ), 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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 ) CALL ZTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**H C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * 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) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO CALL ZTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) CALL ZGEMM( 'N', 'N', L, N, M-L, ONE, V( KP, MP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL ZGEMM( 'N', 'N', K-L, N, M, ONE, V, LDV, B, LDB, $ ZERO, WORK, 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', '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( '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, $ WORK, LDWORK, ONE, B, LDB ) CALL ZTRMM( 'L', 'U', 'C', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**H where C = [ B A ] (A is M-by-K, B is M-by-N) * * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - (A + B V**H) T or A = A - (A + B V**H) T**H * B = B - (A + B V**H) T V or B = B - (A + B V**H) T**H V * * --------------------------------------------------------------------------- * 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 ) END DO END DO CALL ZTRMM( 'R', 'U', 'C', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) 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 ) * 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, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * 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, $ V, LDV, ONE, B, LDB ) CALL ZTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * END IF * RETURN * * End of ZTPRFB * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztrevc.f000066400000000000000000000351641522610125300263000ustar00rootroot00000000000000*> \brief \b ZTREVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTREVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTREVC 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. *> \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 (2*N) *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is DOUBLE PRECISION 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 November 2017 * *> \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 ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, 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 CMZERO, CMONE PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ), $ CMONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV INTEGER I, II, IS, J, K, KI DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZASUM EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM * .. * .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS, DLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( 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 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 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * 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+N ) = 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. * 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 ) * WORK( 1 ) = CMONE * * Form right-hand side. * DO 40 K = 1, KI - 1 WORK( K ) = -T( K, KI ) 40 CONTINUE * * Solve the 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 ), SCALE, RWORK, $ INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL ZCOPY( KI, WORK( 1 ), 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 ) = CMZERO 60 CONTINUE ELSE IF( KI.GT.1 ) $ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), $ 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 ) END IF * * Set back the original diagonal elements of T. * DO 70 K = 1, KI - 1 T( K, K ) = WORK( K+N ) 70 CONTINUE * IS = IS - 1 80 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * 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 ) * WORK( N ) = CMONE * * Form right-hand side. * DO 90 K = KI + 1, N WORK( K ) = -DCONJG( T( KI, K ) ) 90 CONTINUE * * Solve the 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 ), SCALE, RWORK, INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL ZCOPY( N-KI+1, WORK( KI ), 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 ) = CMZERO 110 CONTINUE ELSE IF( KI.LT.N ) $ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1 ), 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 ) END IF * * Set back the original diagonal elements of T. * DO 120 K = KI + 1, N T( K, K ) = WORK( K+N ) 120 CONTINUE * IS = IS + 1 130 CONTINUE END IF * RETURN * * End of ZTREVC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztrexc.f000066400000000000000000000145631522610125300263020ustar00rootroot00000000000000*> \brief \b ZTREXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTREXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. * COMPLEX*16 Q( LDQ, * ), T( LDT, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTREXC reorders the Schur factorization of a complex matrix *> A = Q*T*Q**H, so that the diagonal element of T with row index IFST *> is moved to row ILST. *> *> The Schur form T is reordered by a unitary similarity transformation *> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by *> postmultplying it with Z. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] N *> \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 *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,N) *> On entry, the upper triangular matrix T. *> On exit, the reordered upper triangular matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> unitary transformation matrix Z which reorders T. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1, and if *> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in] ILST *> \verbatim *> ILST is INTEGER *> *> Specify the reordering of the diagonal elements of T: *> The element with row index IFST is moved to row ILST by a *> sequence of transpositions between adjacent elements. *> 1 <= IFST <= N; 1 <= ILST <= 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 complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, 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 COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. COMPLEX*16 Q( LDQ, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL WANTQ INTEGER K, M1, M2, M3 DOUBLE PRECISION CS COMPLEX*16 SN, T11, T22, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZROT * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN 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 ).AND.( N.GT.0 )) THEN INFO = -7 ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Move the IFST-th diagonal element forward down the diagonal. * M1 = 0 M2 = -1 M3 = 1 ELSE * * Move the IFST-th diagonal element backward up the diagonal. * M1 = -1 M2 = 0 M3 = -1 END IF * DO 10 K = IFST + M1, ILST + M2, M3 * * Interchange the k-th and (k+1)-th diagonal elements. * T11 = T( K, K ) T22 = T( K+1, K+1 ) * * Determine the transformation to perform the interchange. * CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( K+2.LE.N ) $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, $ SN ) CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, $ DCONJG( SN ) ) * T( K, K ) = T22 T( K+1, K+1 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, $ DCONJG( SN ) ) END IF * 10 CONTINUE * RETURN * * End of ZTREXC * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztrsen.f000066400000000000000000000331031522610125300262770ustar00rootroot00000000000000*> \brief \b ZTRSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTRSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTRSEN reorders the Schur factorization of a complex matrix *> A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in *> the leading positions on the diagonal of the upper triangular matrix *> T, and the leading columns of Q form an orthonormal basis of the *> corresponding right invariant subspace. *> *> Optionally the routine computes the reciprocal condition numbers of *> the cluster of eigenvalues and/or the invariant subspace. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (S) or the invariant subspace (SEP): *> = 'N': none; *> = 'E': for eigenvalues only (S); *> = 'V': for invariant subspace only (SEP); *> = 'B': for both eigenvalues and invariant subspace (S and *> SEP). *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. *> \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) *> On entry, the upper triangular matrix T. *> On exit, T is overwritten by the reordered matrix T, with the *> selected eigenvalues as the leading diagonal elements. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> unitary transformation matrix which reorders T; the leading M *> columns of Q form an orthonormal basis for the specified *> invariant subspace. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is COMPLEX*16 array, dimension (N) *> The reordered eigenvalues of T, in the same order as they *> appear on the diagonal of T. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified invariant subspace. *> 0 <= M <= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION *> If JOB = 'E' or 'B', S is a lower bound on the reciprocal *> condition number for the selected cluster of eigenvalues. *> S cannot underestimate the true reciprocal condition number *> by more than a factor of sqrt(N). If M = 0 or N, S = 1. *> If JOB = 'N' or 'V', S is not referenced. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is DOUBLE PRECISION *> If JOB = 'V' or 'B', SEP is the estimated reciprocal *> condition number of the specified invariant subspace. If *> M = 0 or N, SEP = norm(T). *> If JOB = 'N' or 'E', SEP is not referenced. *> \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 JOB = 'N', LWORK >= 1; *> if JOB = 'E', LWORK = max(1,M*(N-M)); *> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-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. * *> \date December 2016 * *> \ingroup complex16OTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> ZTRSEN first collects the selected eigenvalues by computing a unitary *> transformation Z to move them to the top left corner of T. In other *> words, the selected eigenvalues are the eigenvalues of T11 in: *> *> Z**H * T * Z = ( T11 T12 ) n1 *> ( 0 T22 ) n2 *> n1 n2 *> *> where N = n1+n2. The first *> n1 columns of Z span the specified invariant subspace of T. *> *> If T has been obtained from the Schur factorization of a matrix *> A = Q*T*Q**H, then the reordered Schur factorization of A is given by *> A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the *> corresponding invariant subspace of A. *> *> The reciprocal condition number of the average of the eigenvalues of *> T11 may be returned in S. S lies between 0 (very badly conditioned) *> and 1 (very well conditioned). It is computed as follows. First we *> compute R so that *> *> P = ( I R ) n1 *> ( 0 0 ) n2 *> n1 n2 *> *> is the projector on the invariant subspace associated with T11. *> R is the solution of the Sylvester equation: *> *> T11*R - R*T22 = T12. *> *> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote *> the two-norm of M. Then S is computed as the lower bound *> *> (1 + F-norm(R)**2)**(-1/2) *> *> on the reciprocal of 2-norm(P), the true reciprocal condition number. *> S cannot underestimate 1 / 2-norm(P) by more than a factor of *> sqrt(N). *> *> An approximate error bound for the computed average of the *> eigenvalues of T11 is *> *> EPS * norm(T) / S *> *> where EPS is the machine precision. *> *> The reciprocal condition number of the right invariant subspace *> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. *> SEP is defined as the separation of T11 and T22: *> *> sep( T11, T22 ) = sigma-min( C ) *> *> where sigma-min(C) is the smallest singular value of the *> n1*n2-by-n1*n2 matrix *> *> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) *> *> I(m) is an m by m identity matrix, and kprod denotes the Kronecker *> product. We estimate sigma-min(C) by the reciprocal of an estimate of *> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) *> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). *> *> When SEP is small, small changes in T can cause large changes in *> the invariant subspace. An approximate bound on the maximum angular *> error in the computed right invariant subspace is *> *> EPS * norm(T) / SEP *> \endverbatim *> * ===================================================================== SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, 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 COMPQ, JOB INTEGER INFO, LDQ, LDT, LWORK, M, N DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION ZLANGE EXTERNAL LSAME, ZLANGE * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters. * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * * Set M to the number of selected eigenvalues. * M = 0 DO 10 K = 1, N IF( SELECT( K ) ) $ M = M + 1 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) * IF( WANTSP ) THEN LWMIN = MAX( 1, 2*NN ) ELSE IF( LSAME( JOB, 'N' ) ) THEN LWMIN = 1 ELSE IF( LSAME( JOB, 'E' ) ) THEN LWMIN = MAX( 1, NN ) END IF * IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = ZLANGE( '1', N, N, T, LDT, RWORK ) GO TO 40 END IF * * Collect the selected eigenvalues at the top left corner of T. * KS = 0 DO 20 K = 1, N IF( SELECT( K ) ) THEN KS = KS + 1 * * Swap the K-th eigenvalue to position KS. * IF( K.NE.KS ) $ CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR ) END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve the Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11**H*R - R*T22**H = scale*X. * CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Copy reordered eigenvalues to W. * DO 50 K = 1, N W( K ) = T( K, K ) 50 CONTINUE * WORK( 1 ) = LWMIN * RETURN * * End of ZTRSEN * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztrsyl.f000066400000000000000000000325671522610125300263360ustar00rootroot00000000000000*> \brief \b ZTRSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTRSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTRSYL solves the complex Sylvester matrix equation: *> *> op(A)*X + X*op(B) = scale*C or *> op(A)*X - X*op(B) = scale*C, *> *> where op(A) = A or A**H, and A and B are both upper triangular. A is *> M-by-M and B is N-by-N; the right hand side C and the solution X are *> M-by-N; and scale is an output scale factor, set <= 1 to avoid *> overflow in X. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANA *> \verbatim *> TRANA is CHARACTER*1 *> Specifies the option op(A): *> = 'N': op(A) = A (No transpose) *> = 'C': op(A) = A**H (Conjugate transpose) *> \endverbatim *> *> \param[in] TRANB *> \verbatim *> TRANB is CHARACTER*1 *> Specifies the option op(B): *> = 'N': op(B) = B (No transpose) *> = 'C': op(B) = B**H (Conjugate transpose) *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> Specifies the sign in the equation: *> = +1: solve op(A)*X + X*op(B) = scale*C *> = -1: solve op(A)*X - X*op(B) = scale*C *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrix A, and the number of rows in the *> matrices X and C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B, and the number of columns in the *> matrices X and C. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,M) *> The upper triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB,N) *> The upper triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is COMPLEX*16 array, dimension (LDC,N) *> On entry, the M-by-N right hand side matrix C. *> On exit, C is overwritten by the solution matrix X. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M) *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scale factor, scale, set <= 1 to avoid overflow in X. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: A and B have common or very close eigenvalues; perturbed *> values were used to solve the equation (but the matrices *> A and B are unchanged). *> \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 ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, 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 TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER J, K, L DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM COMPLEX*16 A11, SUML, SUMR, VEC, X11 * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE COMPLEX*16 ZDOTC, ZDOTU, ZLADIV EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRSYL', -INFO ) RETURN END IF * * Quick return if possible * SCALE = ONE IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) ) SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * DO 30 L = 1, N DO 20 K = M, 1, -1 * SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = A( K, K ) + SGN*B( L, L ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 20 CONTINUE 30 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A**H *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * DO 60 L = 1, N DO 50 K = 1, M * SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = DCONJG( A( K, K ) ) + SGN*B( L, L ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 50 CONTINUE 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A**H*X + ISGN*X*B**H = C. * * The (K,L)th block of X is determined starting from * upper-right corner column by column by * * A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L) * * Where * K-1 * R(K,L) = SUM [A**H(I,K)*X(I,L)] + * I=1 * N * ISGN*SUM [X(K,J)*B**H(L,J)]. * J=L+1 * DO 90 L = N, 1, -1 DO 80 K = 1, M * SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) * SCALOC = ONE A11 = DCONJG( A( K, K )+SGN*B( L, L ) ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 80 CONTINUE 90 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B**H = C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)] * I=K+1 J=L+1 * DO 120 L = N, 1, -1 DO 110 K = M, 1, -1 * SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) * SCALOC = ONE A11 = A( K, K ) + SGN*DCONJG( B( L, L ) ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 110 CONTINUE 120 CONTINUE * END IF * RETURN * * End of ZTRSYL * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/ztrti2.f000066400000000000000000000134371522610125300262200ustar00rootroot00000000000000*> \brief \b ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZTRTI2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZTRTI2 computes the inverse of a complex upper or lower triangular *> matrix. *> *> This is the Level 2 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit 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 triangular matrix A. If UPLO = 'U', the *> leading n by n upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. If DIAG = 'U', the *> diagonal elements of A are also not referenced and are *> assumed to be 1. *> *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 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 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J COMPLEX*16 AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZSCAL, ZTRMV * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, '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.NE.0 ) THEN CALL XERBLA( 'ZTRTI2', -INFO ) RETURN END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE * * Compute inverse of lower triangular matrix. * DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF * RETURN * * End of ZTRTI2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zung2r.f000066400000000000000000000121001522610125300261730ustar00rootroot00000000000000*> \brief \b ZUNG2R * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNG2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZUNG2R generates an m by n complex matrix Q with orthonormal columns, *> which is defined as the first n columns of a product of k elementary *> reflectors of order m *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by ZGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by ZGEQRF in the first k columns of its array *> argument A. *> On exit, the m by n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGEQRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has 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 * * ===================================================================== SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, 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, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNG2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunghr.f000066400000000000000000000147071522610125300263000ustar00rootroot00000000000000*> \brief \b ZUNGHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNGHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZUNGHR generates a complex unitary matrix Q which is defined as the *> product of IHI-ILO elementary reflectors of order N, as returned by *> ZGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of ZGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by ZGEHRD. *> On exit, the N-by-N unitary matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGEHRD. *> \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. LWORK >= IHI-ILO. *> For optimum performance LWORK >= (IHI-ILO)*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 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), 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 LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGQR * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNGHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zungqr.f000066400000000000000000000176101522610125300263050ustar00rootroot00000000000000*> \brief \b ZUNGQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNGQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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: * ============= *> *> \verbatim *> *> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, *> which is defined as the first N columns of a product of K elementary *> reflectors of order M *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by ZGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. 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,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by ZGEQRF in the first k columns of its array *> argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGEQRF. *> \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. LWORK >= max(1,N). *> For optimum performance LWORK >= 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 has 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 * * ===================================================================== SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, 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, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL ZLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zungtsqr.f000066400000000000000000000220761522610125300266560ustar00rootroot00000000000000*> \brief \b ZUNGTSQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNGTSQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> * Definition: * =========== * * SUBROUTINE ZUNGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, * $ INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) * .. * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal *> columns, which are the first N columns of a product of comlpex unitary *> matrices of order M which are returned by ZLATSQR *> *> Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). *> *> See the documentation for ZLATSQR. *> \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 used by DLATSQR to return *> arrays A and T. MB > N. *> (Note that if MB > M, then M is used instead of MB *> as the row block size). *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The column block size used by ZLATSQR to return *> arrays A and T. NB >= 1. *> (Note that if NB > N, then N is used instead of NB *> as the column block size). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) *> *> On entry: *> *> The elements on and above the diagonal are not accessed. *> The elements below the diagonal represent the unit *> lower-trapezoidal blocked matrix V computed by ZLATSQR *> that defines the input matrices Q_in(k) (ones on the *> diagonal are not stored) (same format as the output A *> below the diagonal in ZLATSQR). *> *> On exit: *> *> The array A contains an M-by-N orthonormal matrix Q_out, *> i.e the columns of A are orthogonal unit vectors. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] T *> \verbatim *> T is COMPLEX*16 array, *> dimension (LDT, N * NIRB) *> where NIRB = Number_of_input_row_blocks *> = MAX( 1, CEIL((M-N)/(MB-N)) ) *> Let NICB = Number_of_input_col_blocks *> = CEIL(N/NB) *> *> The upper-triangular block reflectors used to define the *> input matrices Q_in(k), k=(1:NIRB*NICB). The block *> reflectors are stored in compact form in NIRB block *> reflector sequences. Each of NIRB block reflector sequences *> is stored in a larger NB-by-N column block of T and consists *> of NICB smaller NB-by-NB upper-triangular column blocks. *> (same format as the output T in ZLATSQR). *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= max(1,min(NB1,N)). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> (workspace) COMPLEX*16 array, dimension (MAX(2,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> The dimension of the array WORK. LWORK >= (M+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. * *> \date November 2019 * *> \ingroup comlex16OTHERcomputational * *> \par Contributors: * ================== *> *> \verbatim *> *> November 2019, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> *> \endverbatim * * ===================================================================== SUBROUTINE ZUNGTSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, $ INFO ) IMPLICIT NONE * * -- LAPACK computational routine (version 3.9.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2019 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER IINFO, LDC, LWORKOPT, LC, LW, NBLOCAL, J * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZLAMTSQR, ZLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * LQUERY = LWORK.EQ.-1 INFO = 0 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 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDT.LT.MAX( 1, MIN( NB, N ) ) ) THEN INFO = -8 ELSE * * Test the input LWORK for the dimension of the array WORK. * This workspace is used to store array C(LDC, N) and WORK(LWORK) * in the call to ZLAMTSQR. See the documentation for ZLAMTSQR. * IF( LWORK.LT.2 .AND. (.NOT.LQUERY) ) THEN INFO = -10 ELSE * * Set block size for column blocks * NBLOCAL = MIN( NB, N ) * * LWORK = -1, then set the size for the array C(LDC,N) * in ZLAMTSQR call and set the optimal size of the work array * WORK(LWORK) in ZLAMTSQR call. * LDC = M LC = LDC*N LW = N * NBLOCAL * LWORKOPT = LC+LW * IF( ( LWORK.LT.MAX( 1, LWORKOPT ) ).AND.(.NOT.LQUERY) ) THEN INFO = -10 END IF END IF * END IF * * Handle error in the input parameters and return workspace query. * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGTSQR', -INFO ) RETURN ELSE IF ( LQUERY ) THEN WORK( 1 ) = DCMPLX( LWORKOPT ) RETURN END IF * * Quick return if possible * IF( MIN( M, N ).EQ.0 ) THEN WORK( 1 ) = DCMPLX( LWORKOPT ) RETURN END IF * * (1) Form explicitly the tall-skinny M-by-N left submatrix Q1_in * of M-by-M orthogonal matrix Q_in, which is implicitly stored in * the subdiagonal part of input array A and in the input array T. * Perform by the following operation using the routine ZLAMTSQR. * * Q1_in = Q_in * ( I ), where I is a N-by-N identity matrix, * ( 0 ) 0 is a (M-N)-by-N zero matrix. * * (1a) Form M-by-N matrix in the array WORK(1:LDC*N) with ones * on the diagonal and zeros elsewhere. * CALL ZLASET( 'F', M, N, CZERO, CONE, WORK, LDC ) * * (1b) On input, WORK(1:LDC*N) stores ( I ); * ( 0 ) * * On output, WORK(1:LDC*N) stores Q1_in. * CALL ZLAMTSQR( 'L', 'N', M, N, N, MB, NBLOCAL, A, LDA, T, LDT, $ WORK, LDC, WORK( LC+1 ), LW, IINFO ) * * (2) Copy the result from the part of the work array (1:M,1:N) * with the leading dimension LDC that starts at WORK(1) into * the output array A(1:M,1:N) column-by-column. * DO J = 1, N CALL ZCOPY( M, WORK( (J-1)*LDC + 1 ), 1, A( 1, J ), 1 ) END DO * WORK( 1 ) = DCMPLX( LWORKOPT ) RETURN * * End of ZUNGTSQR * ENDqrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunm2r.f000066400000000000000000000165521522610125300262200ustar00rootroot00000000000000*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNM2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNM2R overwrites the general complex m-by-n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**H* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**H if SIDE = 'R' and TRANS = 'C', *> *> where Q is a complex unitary matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by ZGEQRF. 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**H from the Left *> = 'R': apply Q or Q**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> ZGEQRF in the first k columns of its array argument A. *> A is modified by the routine but restored on exit. *> \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] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGEQRF. *> \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**H*C or C*Q**H 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, dimension *> (N) if SIDE = 'L', *> (M) 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 complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)**H * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = DCONJG( TAU( I ) ) END IF AII = A( I, I ) A( I, I ) = ONE CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, $ WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of ZUNM2R * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunmbr.f000066400000000000000000000255531522610125300263010ustar00rootroot00000000000000*> \brief \b ZUNMBR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNMBR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'C': Q**H * C C * Q**H *> *> If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': P * C C * P *> TRANS = 'C': P**H * C C * P**H *> *> Here Q and P**H are the unitary matrices determined by ZGEBRD when *> reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q *> and P**H are defined as products of elementary reflectors H(i) and *> G(i) respectively. *> *> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the *> order of the unitary matrix Q or P**H that is applied. *> *> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: *> if nq >= k, Q = H(1) H(2) . . . H(k); *> if nq < k, Q = H(1) H(2) . . . H(nq-1). *> *> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: *> if k < nq, P = G(1) G(2) . . . G(k); *> if k >= nq, P = G(1) G(2) . . . G(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'Q': apply Q or Q**H; *> = 'P': apply P or P**H. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q, Q**H, P or P**H from the Left; *> = 'R': apply Q, Q**H, P or P**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q or P; *> = 'C': Conjugate transpose, apply Q**H or P**H. *> \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 *> If VECT = 'Q', the number of columns in the original *> matrix reduced by ZGEBRD. *> If VECT = 'P', the number of rows in the original *> matrix reduced by ZGEBRD. *> K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension *> (LDA,min(nq,K)) if VECT = 'Q' *> (LDA,nq) if VECT = 'P' *> The vectors which define the elementary reflectors H(i) and *> G(i), whose products determine the matrices Q and P, as *> returned by ZGEBRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If VECT = 'Q', LDA >= max(1,nq); *> if VECT = 'P', LDA >= max(1,min(nq,K)). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (min(nq,K)) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i) or G(i) which determines Q or P, as returned *> by ZGEBRD in the array argument TAUQ or TAUP. *> \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**H*C or C*Q**H or C*Q *> or P*C or P**H*C or C*P or C*P**H. *> \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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M); *> if N = 0 or M = 0, LWORK >= 1. *> For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', *> and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the *> optimal blocksize. (NB = 0 if M = 0 or N = 0.) *> *> 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 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, 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, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNMLQ, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( M.EQ.0 .OR. N.EQ.0 ) THEN NW = 0 END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( K.LT.0 ) THEN INFO = -6 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) $ THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( NW.GT.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW*NB ) ELSE LWKOPT = 1 END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to ZGEBRD with nq >= k * CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to ZGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to ZGEBRD with nq > k * CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to ZGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMBR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunmhr.f000066400000000000000000000202471522610125300263020ustar00rootroot00000000000000*> \brief \b ZUNMHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNMHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNMHR overwrites the general complex 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 of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> IHI-ILO elementary reflectors, as returned by ZGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of ZGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and *> ILO = 1 and IHI = 0, if M = 0; *> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and *> ILO = 1 and IHI = 0, if N = 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension *> (LDA,M) if SIDE = 'L' *> (LDA,N) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by ZGEHRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGEHRD. *> \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**H*C or C*Q**H 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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', 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 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, 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 IHI, ILO, INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LEFT = LSAME( SIDE, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) $ THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN INFO = -5 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 ) ELSE NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 ) END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = NH NI = N I1 = ILO + 1 I2 = 1 ELSE MI = M NI = NH I1 = 1 I2 = ILO + 1 END IF * CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) * WORK( 1 ) = LWKOPT RETURN * * End of ZUNMHR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunml2.f000066400000000000000000000170501522610125300262040ustar00rootroot00000000000000*> \brief \b ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNML2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNML2 overwrites the general complex m-by-n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**H* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**H if SIDE = 'R' and TRANS = 'C', *> *> where Q is a complex unitary matrix defined as the product of k *> elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H *> *> as returned by ZGELQF. 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**H from the Left *> = 'R': apply Q or Q**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] A *> \verbatim *> A is COMPLEX*16 array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> ZGELQF in the first k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGELQF. *> \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**H*C or C*Q**H 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, dimension *> (N) if SIDE = 'L', *> (M) 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 complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNML2', -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 .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)**H * IF( NOTRAN ) THEN TAUI = DCONJG( TAU( I ) ) ELSE TAUI = TAU( I ) END IF IF( I.LT.NQ ) $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) AII = A( I, I ) A( I, I ) = ONE CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII IF( I.LT.NQ ) $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) 10 CONTINUE RETURN * * End of ZUNML2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunmlq.f000066400000000000000000000225031522610125300263020ustar00rootroot00000000000000*> \brief \b ZUNMLQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNMLQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNMLQ overwrites the general complex 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 k *> elementary reflectors *> *> Q = H(k)**H . . . H(2)**H H(1)**H *> *> as returned by ZGELQF. 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Conjugate transpose, apply Q**H. *> \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] A *> \verbatim *> A is COMPLEX*16 array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> ZGELQF 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. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGELQF. *> \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**H*C or C*Q**H 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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**H * CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, $ A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMLQ * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunmqr.f000066400000000000000000000222311522610125300263060ustar00rootroot00000000000000*> \brief \b ZUNMQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNMQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNMQR overwrites the general complex 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 k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by ZGEQRF. 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**H from the Left; *> = 'R': apply Q or Q**H from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Conjugate transpose, apply Q**H. *> \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] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> ZGEQRF 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] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGEQRF. *> \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**H*C or C*Q**H 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, 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 SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> 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 *> 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 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**H is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**H is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**H * CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMQR * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/lapack-missing/src/zunmr2.f000066400000000000000000000166411522610125300262170ustar00rootroot00000000000000*> \brief \b ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNMR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \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 * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ZUNMR2 overwrites the general complex m-by-n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**H* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**H if SIDE = 'R' and TRANS = 'C', *> *> where Q is a complex unitary matrix defined as the product of k *> elementary reflectors *> *> Q = H(1)**H H(2)**H . . . H(k)**H *> *> as returned by ZGERQF. 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**H from the Left *> = 'R': apply Q or Q**H from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'C': apply Q**H (Conjugate transpose) *> \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] A *> \verbatim *> A is COMPLEX*16 array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> ZGERQF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by ZGERQF. *> \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**H*C or C*Q**H 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, dimension *> (N) if SIDE = 'L', *> (M) 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 complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) 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.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) or H(i)**H is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) or H(i)**H * IF( NOTRAN ) THEN TAUI = DCONJG( TAU( I ) ) ELSE TAUI = TAU( I ) END IF CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA ) AII = A( I, NQ-K+I ) A( I, NQ-K+I ) = ONE CALL ZLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK ) A( I, NQ-K+I ) = AII CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA ) 10 CONTINUE RETURN * * End of ZUNMR2 * END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/qrupdate-config.cmake.in000066400000000000000000000003251522610125300256110ustar00rootroot00000000000000include(CMakeFindDependencyMacro) # Same syntax as find_package find_dependency(BLAS REQUIRED) find_dependency(LAPACK REQUIRED) # Add the targets file include("${CMAKE_CURRENT_LIST_DIR}/qrupdateTargets.cmake") qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/qrupdate.pc.in000066400000000000000000000004611522610125300236710ustar00rootroot00000000000000prefix=@CMAKE_INSTALL_PREFIX@ exec_prefix=@CMAKE_INSTALL_PREFIX@ includedir=@CMAKE_INSTALL_FULL_INCLUDEDIR@ libdir=@CMAKE_INSTALL_FULL_LIBDIR@ Name: qrupdate Description: The qrupdate library Version: @PROJECT_VERSION@ Requires: blas, lapack Cflags: -I${includedir}/qrupdate Libs: -L${libdir} -lqrupdate qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/000077500000000000000000000000001522610125300217015ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/CMakeLists.txt000066400000000000000000000066661522610125300244570ustar00rootroot00000000000000SET(SRC qrupdate.f90 qrupdate_blas.f90 qrupdate_error.f90 caxcpy.f90 cch1dn.f90 cch1up.f90 cchdex.f90 cchinx.f90 cchshx.f90 cdotc.f90 cdotu.f90 cgqvec.f90 clu1up.f90 clup1up.f90 cqhqr.f90 cqr1up.f90 cqrdec.f90 cqrder.f90 cqrinc.f90 cqrinr.f90 cqrot.f90 cqrqh.f90 cqrshc.f90 cqrtv1.f90 dch1dn.f90 dch1up.f90 dchdex.f90 dchinx.f90 dchshx.f90 dgqvec.f90 dlu1up.f90 dlup1up.f90 dqhqr.f90 dqr1up.f90 dqrdec.f90 dqrder.f90 dqrinc.f90 dqrinr.f90 dqrot.f90 dqrqh.f90 dqrshc.f90 dqrtv1.f90 sch1dn.f90 sch1up.f90 schdex.f90 schinx.f90 schshx.f90 sgqvec.f90 slu1up.f90 slup1up.f90 sqhqr.f90 sqr1up.f90 sqrdec.f90 sqrder.f90 sqrinc.f90 sqrinr.f90 sqrot.f90 sqrqh.f90 sqrshc.f90 sqrtv1.f90 zaxcpy.f90 zch1dn.f90 zch1up.f90 zchdex.f90 zchinx.f90 zchshx.f90 zdotc.f90 zdotu.f90 zgqvec.f90 zlu1up.f90 zlup1up.f90 zqhqr.f90 zqr1up.f90 zqrdec.f90 zqrder.f90 zqrinc.f90 zqrinr.f90 zqrot.f90 zqrqh.f90 zqrshc.f90 zqrtv1.f90 ) SET(ITARGETS) IF (TARGET lapack_missing) if (BUILD_SHARED_LIBS) ADD_LIBRARY(qrupdate SHARED ${SRC} $) endif() if (BUILD_STATIC_LIBS) ADD_LIBRARY(qrupdate_static STATIC ${SRC} $) endif() ELSE() if (BUILD_SHARED_LIBS) ADD_LIBRARY(qrupdate SHARED ${SRC}) endif() if (BUILD_STATIC_LIBS) ADD_LIBRARY(qrupdate_static STATIC ${SRC}) endif() ENDIF() if (BUILD_SHARED_LIBS) TARGET_LINK_LIBRARIES(qrupdate PRIVATE LAPACK::LAPACK BLAS::BLAS) add_library(qrupdate::qrupdate ALIAS qrupdate) SET_PROPERTY(TARGET qrupdate PROPERTY VERSION ${PROJECT_VERSION}) SET_PROPERTY(TARGET qrupdate PROPERTY SOVERSION ${PROJECT_VERSION_MAJOR}) SET_TARGET_PROPERTIES(qrupdate PROPERTIES Fortran_MODULE_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/fortran-modules") TARGET_INCLUDE_DIRECTORIES(qrupdate PUBLIC $ $ ) ADD_COVERAGE(qrupdate) list(APPEND ITARGETS qrupdate) endif() if (BUILD_STATIC_LIBS) TARGET_LINK_LIBRARIES(qrupdate_static PRIVATE LAPACK::LAPACK BLAS::BLAS) add_library(qrupdate::qrupdate_static ALIAS qrupdate_static) SET_TARGET_PROPERTIES(qrupdate_static PROPERTIES Fortran_MODULE_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/fortran-modules-static") SET_TARGET_PROPERTIES(qrupdate_static PROPERTIES OUTPUT_NAME qrupdate) TARGET_INCLUDE_DIRECTORIES(qrupdate_static PUBLIC $ $ ) list(APPEND ITARGETS qrupdate_static ) ADD_COVERAGE(qrupdate_static) endif() if (BUILD_SHARED_LIBS) INSTALL(DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/fortran-modules/" DESTINATION ${CMAKE_INSTALL_FULL_MODULEDIR} ) else() INSTALL(DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/fortran-modules-static/" DESTINATION ${CMAKE_INSTALL_FULL_MODULEDIR} ) endif() INSTALL(TARGETS ${ITARGETS} EXPORT qrupdatetargets LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} ) qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/categories.doxy000066400000000000000000000046521522610125300247420ustar00rootroot00000000000000/** \defgroup qrdecomp QR Decomposition \brief Routines for the computation and efficient updating of the QR factorization of a matrix. This group provides routines for modifying the original matrix via rank-1 updates, row/column insertions, deletions, or shifts, and updating the corresponding orthogonal matrix Q and upper trapezoidal matrix R without recomputing the entire decomposition from scratch. It supports both full and economized QR factorizations and relies on Givens rotations for maintaining the triangular structure of the R matrix. \defgroup choldecomp Cholesky Decomposition \brief Routines for the Cholesky factorization of symmetric positive definite matrices and their updates. This group implements methods to update the Cholesky factorization after matrix modifications, including rank-1 updates, downdates, and symmetric updates for column/row insertion, deletion, and circular shifts. The updates use Givens rotations to restore the upper triangular form of the factor. \defgroup ludecomp LU Decomposition \brief Routines for updating the LU factorization of a matrix after a rank-1 modification. This group provides both standard LU updates and pivoted LU updates (handling row permutations for stability). The updates are implemented using the Bennett algorithm, which is significantly more efficient than full re-decomposition. \defgroup aux Auxilliary Subroutines \brief Collection of helper routines for basic linear algebra and specialized vector operations. This group provides utilities that fill gaps in standard BLAS implementations or provide specialized operations required by the library, such as scaled conjugate vector addition (axcpy), which are used across the various decomposition update routines. \defgroup givens Givens Rotations \brief Routines for the generation and application of Givens rotations. As a foundational component, this group implements the primary mechanism for maintaining triangular structures in the QR and Cholesky decompositions. It includes routines for generating rotation coefficients and applying rotations to matrices in both forward and backward orders. \ingroup aux \defgroup error Error Handling \brief Routines for error handling. Since qrupdate 1.2.0, the way of handling errors changed a bit. Instead of calling xerbla from LAPACK/BLAS, a user defined handler can registered. If this is not done, xerbla is called as before. See \ref qrupdate_set_error for details. \ingroup aux */ qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/caxcpy.f90000066400000000000000000000076211522610125300235160ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Performs scaled conjugate vector addition. !> !> \par Definition: ! ============= !> \verbatim !> subroutine caxcpy(n,a,x,incx,y,incy) !> !> .. Scalar Arguments .. !> integer n, incx, incy !> .. !> .. Array Arguments .. !> complex a, x(*), y(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CAXCPY performs the operation y := y + a * conjg(x), where a is a !> complex scalar, x is a vector of length n, conjg(x) denotes the !> element-wise complex conjugate of x, and y is a vector of the same !> length. On entry, y contains the existing values; on exit, y is !> overwritten with the result. This is the complex analogue of the !> BLAS caxpy, with the x argument conjugated before scaling. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of elements in vectors x and y. If n <= 0, !> the subroutine returns immediately without modification. !> \endverbatim !> !> \param[in] a !> \verbatim !> a is COMPLEX !> The complex scalar used to scale the conjugated vector !> conjg(x) before accumulation into y. !> \endverbatim !> !> \param[in] x !> \verbatim !> x is COMPLEX array, dimension (*) !> The vector whose complex conjugate is scaled by a and !> added to y. x is not modified. !> \endverbatim !> !> \param[in] incx !> \verbatim !> incx is INTEGER !> The stride (increment) for elements of x. If incx > 0, !> elements are accessed starting from x(1); if incx < 0, !> elements are accessed starting from !> x(1 + (-n+1)*incx). A value of 1 accesses !> contiguous elements. !> \endverbatim !> !> \param[in,out] y !> \verbatim !> y is COMPLEX array, dimension (*) !> On entry, the vector y of length n. On exit, y is !> overwritten with y + a * conjg(x). !> \endverbatim !> !> \param[in] incy !> \verbatim !> incy is INTEGER !> The stride (increment) for elements of y. If incy > 0, !> elements are accessed starting from y(1); if incy < 0, !> elements are accessed starting from !> y(1 + (-n+1)*incy). A value of 1 accesses !> contiguous elements. !> \endverbatim !> \ingroup aux subroutine caxcpy(n,a,x,incx,y,incy) use iso_fortran_env integer, intent(in) :: n, incx, incy complex(real32), intent(in) :: a, x(*) complex(real32), intent(inout) :: y(*) integer i,ix,iy ! quick return if possible. if (n <= 0) return if (incx /= 1 .or. incy /= 1) then ! code for unequal increments or equal increments not equal to 1 ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n y(iy) = y(iy) + a*conjg(x(ix)) ix = ix + incx iy = iy + incy end do else ! code for both increments equal to 1 do i = 1,n y(i) = y(i) + a*conjg(x(i)) end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cch1dn.f90000066400000000000000000000107721522610125300233700ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Downdates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cch1dn(n,R,ldr,u,rw,info) !> !> .. Scalar Arguments .. !> integer n, ldr, info !> .. !> .. Array Arguments .. !> complex R(ldr,*), u(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CCH1DN downdates the Cholesky factorization of a hermitian !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R'*R, where R' denotes the conjugate transpose of R, this !> CCH1DN downdates R -> R1 so that R1'*R1 = A - u*u', where u !> is a given vector. !> !> The downdate is performed by applying a sequence of hyperbolic !> rotations to restore the upper triangular structure of R. On !> exit, u contains the rotation sines and rw contains the rotation !> cosines used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A - u*u'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX array, dimension (n) !> On entry, the vector determining the rank-1 downdate. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (n) !> On exit, rw contains the cosine parts of the !> rotations used to transform R to R1. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> \endverbatim !> !> \ingroup choldecomp subroutine cch1dn(n,R,ldr,u,rw,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(inout) :: u(*) real(real32), intent(out) :: rw(*) integer, intent(out) :: info external ctrsv,clartg,scnrm2 complex(real32) crho,rr,ui,t real(real32) scnrm2,rho integer i,j ! quick return if possible. if (n == 0) return ! check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call qrupdate_xerror('CCH1DN',-info) return end if ! check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do ! form R' \ u call ctrsv('U','C','N',n,R,ldr,u,1) rho = scnrm2(n,u,1) ! check positive definiteness rho = 1 - rho**2 if (rho <= 0e0) goto 10 crho = sqrt(rho) ! eliminate R' \ u do i = n,1,-1 ui = u(i) ! generate next rotation call clartg(crho,ui,rw(i),u(i),rr) crho = rr end do ! apply rotations do i = n,1,-1 ui = 0e0 do j = i,1,-1 t = rw(j)*ui + u(j)*R(j,i) R(j,i) = rw(j)*R(j,i) - conjg(u(j))*ui ui = t end do end do ! normal return return ! error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cch1up.f90000066400000000000000000000067401522610125300234130ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cch1up(n,R,ldr,u,w) !> !> .. Scalar Arguments .. !> integer n, ldr !> .. !> .. Array Arguments .. !> complex R(ldr,*), u(*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CCH1UP updates the Cholesky factorization of a hermitian !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R'*R, where R' denotes the conjugate transpose of R, this !> CCH1UP updates R -> R1 so that R1'*R1 = A + u*u', where u is !> a given vector. !> !> The update is performed by applying a sequence of Givens rotations !> to restore the upper triangular structure of R. On exit, u !> contains the rotation sines and w contains the rotation cosines !> used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A + u*u'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX array, dimension (n) !> On entry, the vector determining the rank-1 update. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations used to transform R to R1. !> \endverbatim !> !> \ingroup choldecomp subroutine cch1up(n,R,ldr,u,w) use iso_fortran_env integer, intent(in) :: n, ldr complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(inout) :: u(*) real(real32), intent(out) :: w(*) external clartg complex(real32) rr,ui,t integer i,j do i = 1,n ! apply stored rotations, column-wise ui = conjg(u(i)) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - conjg(u(j))*R(j,i) R(j,i) = t end do ! generate next rotation call clartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cchdex.f90000066400000000000000000000062351522610125300234650ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after deleting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cchdex(n,R,ldr,j,rw) !> !> .. Scalar Arguments .. !> integer n, ldr, j !> .. !> .. Array Arguments .. !> complex R(ldr,*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CCHDEX updates the Cholesky factorization of a hermitian !> positive definite matrix A after deleting a row/column. !> Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R'*R, where R' denotes the conjugate !> transpose of R, CCHDEX updates R -> R1 so that !> R1'*R1 = A(jj,jj), where jj = [1:j-1, j+1:n+1]. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(jj,jj). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row/column. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (n) !> A workspace vector. !> \endverbatim !> !> \ingroup choldecomp subroutine cchdex(n,R,ldr,j,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, j complex(real32), intent(inout) :: R(ldr,*) real(real32), intent(out) :: rw(*) integer info,i external ccopy,cqhqr ! quick return if possible. if (n == 1) return ! check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call qrupdate_xerror('CCHDEX',info) return end if ! delete the j-th column. do i = j,n-1 call ccopy(n,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < n) then call cqhqr(n+1-j,n-j,R(j,j),ldr,rw,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cchinx.f90000066400000000000000000000115521522610125300235010ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after inserting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cchinx(n,R,ldr,j,u,rw,info) !> !> .. Scalar Arguments .. !> integer n, j, ldr, info !> .. !> .. Array Arguments .. !> complex R(ldr,*), u(*), rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CCHINX updates the Cholesky factorization of a hermitian !> positive definite matrix A after inserting a row and column. !> Given an upper triangular matrix R that is a Cholesky factor of !> A, i.e., A = R'*R, where R' denotes the conjugate transpose of !> R, CCHINX updates R -> R1 so that R1'*R1 = A1, where !> A1(jj,jj) = A, A1(j,:) = u', A1(:,j) = u, and !> jj = [1:j-1, j+1:n+1]. !> !> On exit, u is destroyed and R is extended by one row and column. !> The insertion is performed by first solving R'*u = v, checking !> positive definiteness, and then retriangularizing. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n+1) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the inserted row and column. !> 1 <= j <= n+1. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX array, dimension (n+1) !> On entry, the vector defining the inserted row/column. !> On exit, u is destroyed. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (n+1) !> Workspace vector used to store rotation cosines during !> the retriangularization. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> = 3: the diagonal element of u is not real !> \endverbatim !> !> \ingroup choldecomp subroutine cchinx(n,R,ldr,j,u,rw,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, j, ldr integer, intent(out) :: info complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(inout) :: u(*) real(real32), intent(out) :: rw(*) external ccopy,scnrm2,ctrsv,cqrtv1,cqrqh complex(real32) t real(real32) scnrm2,rho integer i ! check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call qrupdate_xerror('CCHINX',info) return end if ! shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do ! the diagonal element must be real. if (imag(t) /= 0e0) goto 30 ! check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do ! form R' \ u call ctrsv('U','C','N',n,R,ldr,u,1) rho = scnrm2(n,u,1) ! check positive definiteness. rho = real(t, real32) - rho**2 if (rho <= 0e0) goto 10 ! shift columns do i = n,j,-1 call ccopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0e0 end do call ccopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) ! retriangularize if (j < n+1) then ! eliminate the introduced spike. call cqrtv1(n+2-j,R(j,j),rw) ! apply rotations to R call cqrqh(n+2-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) ! zero spike. do i = j+1,n+1 R(i,j) = 0e0 end do end if ! normal return. return ! error returns. 10 info = 1 return 20 info = 2 return 30 info = 3 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cchshx.f90000066400000000000000000000105761522610125300235120ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a symmetric shift of rows and columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cchshx(n,R,ldr,i,j,w,rw) !> !> .. Scalar Arguments .. !> integer n, ldr, i, j !> .. !> .. Array Arguments .. !> complex R(ldr,*), w(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CCHSHX updates the Cholesky factorization of a hermitian !> positive definite matrix A after a symmetric shift of rows and !> columns. Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R'*R, where R' denotes the conjugate !> transpose of R, CCHSHX updates R -> R1 so that !> R1'*R1 = A(p,p), where p is the permutation !> [1:i-1, shift(i:j,-1), j+1:n] if i < j, or !> [1:j-1, shift(j:i,+1), i+1:n] if j < i. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(p,p). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range of the shift. !> 1 <= i <= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range of the shift. !> 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX array, dimension (n) !> Workspace vector used to store rotation sines during !> the retriangularization. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (n) !> Workspace vector used to store rotation cosines during !> the retriangularization. !> \endverbatim !> !> \ingroup choldecomp subroutine cchshx(n,R,ldr,i,j,w,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, i, j complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(out) :: w(*) real(real32), intent(out) :: rw(*) external ccopy,cqrtv1,cqrqh,cqhqr integer info,l ! quick return if possible. if (n == 0 .or. n == 1) return info = 0 ! check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call qrupdate_xerror('CCHSHX',info) return end if if (i < j) then ! shift columns call ccopy(n,R(1,i),1,w,1) do l = i,j-1 call ccopy(n,R(1,l+1),1,R(1,l),1) end do call ccopy(n,w,1,R(1,j),1) ! retriangularize call cqhqr(n+1-i,n+1-i,R(i,i),ldr,rw,w) else if (j < i) then ! shift columns call ccopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call ccopy(n,R(1,l-1),1,R(1,l),1) end do call ccopy(n,w,1,R(1,j),1) ! eliminate the introduced spike. call cqrtv1(n+1-j,R(j,j),rw) ! apply rotations to R call cqrqh(n+1-j,n-j,R(j,j+1),ldr,rw,R(j+1,j)) ! zero spike. do l = j+1,n R(l,j) = 0e0 end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cdotc.f90000066400000000000000000000065161522610125300233250ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief CDOTC Complex dot product (x**H y version) ! !> \par Definition: ! =========== !> \verbatim !> SUBROUTINE QRUPDATE_CDOTC(RET, N,CX,INCX,CY,INCY) !> !> .. Scalar Arguments .. !> INTEGER INCX,INCY,N !> COMPLEX(real32) ret !> .. !> .. Array Arguments .. !> COMPLEX(real32) CX(*),CY(*) !> .. !> \endverbatim ! !> \par Purpose: ! ============= !> !> \verbatim !> !> CDOTC forms the dot product of two complex vectors !> CDOTC = X^H * Y !> !> \endverbatim ! ! Arguments: ! ========== ! !> \param[out] RET !> \verbatim !> RET is COMPLEX(real32) !> RET contains the dot product. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> number of elements in input vector(s) !> \endverbatim !> !> \param[in] CX !> \verbatim !> CX is COMPLEX(real32) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> storage spacing between elements of CX !> \endverbatim !> !> \param[in] CY !> \verbatim !> CY is COMPLEX(real32) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> storage spacing between elements of CY !> \endverbatim ! !> \remark This routine is equivalent to cdotc from BLAS but invariant with the compiler's Fortran ABI ! !> \ingroup aux ! ===================================================================== subroutine qrupdate_cdotc(ret,n,cx,incx,cy,incy) use iso_fortran_env implicit none ! .. scalar arguments .. integer, intent(in) :: incx,incy,n ! .. ! .. array arguments .. complex(real32), intent(in) :: cx(*),cy(*) complex(real32), intent(out) :: ret ! .. ! ! .. local scalars .. complex(real32) ctemp integer i,ix,iy ! .. ctemp = (0.0,0.0) ret = (0.0,0.0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ctemp = ctemp + conjg(cx(i))*cy(i) end do else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = ctemp + conjg(cx(ix))*cy(iy) ix = ix + incx iy = iy + incy end do end if ret = ctemp return ! ! end of cdotc ! end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cdotu.f90000066400000000000000000000065031522610125300233430ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief CDOTU Complex dot product (x**T y version) ! !> \par Definition: ! =========== !> \verbatim !> SUBROUTINE QRUPDATE_CDOTU(RET, N,CX,INCX,CY,INCY) !> !> .. Scalar Arguments .. !> INTEGER INCX,INCY,N !> COMPLEX(real32) ret !> .. !> .. Array Arguments .. !> COMPLEX(real32) CX(*),CY(*) !> .. !> \endverbatim ! !> \par Purpose: ! ============= !> !> \verbatim !> !> CDOTU forms the dot product of two complex vectors !> CDOTU = X^T * Y !> !> \endverbatim ! ! Arguments: ! ========== ! !> \param[out] RET !> \verbatim !> RET is COMPLEX(real32) !> RET contains the dot product. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> number of elements in input vector(s) !> \endverbatim !> !> \param[in] CX !> \verbatim !> CX is COMPLEX(real32) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> storage spacing between elements of CX !> \endverbatim !> !> \param[in] CY !> \verbatim !> CY is COMPLEX(real32) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> storage spacing between elements of CY !> \endverbatim !> !> \remark This routine is equivalent to cdotu from BLAS but invariant with the compiler's Fortran ABI ! ! !> \ingroup aux ! ===================================================================== subroutine qrupdate_cdotu(ret,n,cx,incx,cy,incy) use iso_fortran_env implicit none ! .. scalar arguments .. integer, intent(in) :: incx,incy,n ! .. ! .. array arguments .. complex(real32), intent(in) :: cx(*),cy(*) complex(real32), intent(out) :: ret ! .. ! ! .. local scalars .. complex(real32) ctemp integer i,ix,iy ! .. ctemp = (0.0,0.0) ret = (0.0,0.0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ctemp = ctemp + cx(i)*cy(i) end do else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = ctemp + cx(ix)*cy(iy) ix = ix + incx iy = iy + incy end do end if ret = ctemp return ! ! end of cdotu ! end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cgqvec.f90000066400000000000000000000075431522610125300235020ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates a unit vector orthogonal to the column space of a unitary matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cgqvec(m,n,Q,ldq,u) !> !> .. Scalar Arguments .. !> integer m, n, ldq !> .. !> .. Array Arguments .. !> complex Q(ldq,*), u(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CGQVEC generates a vector u in the orthogonal complement of the !> column space of a unitary matrix Q. Given an m-by-n unitary !> matrix Q with n < m, CGQVEC generates a vector u of !> length m such that Q'*u = 0 and norm(u) = 1, where Q' denotes !> the conjugate transpose of Q. !> !> The algorithm projects canonical unit vectors onto the orthogonal !> complement of Q's column space until a nonzero result is found. !> If n = 0, the first canonical unit vector is returned. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0 and !> n < m. !> \endverbatim !> !> \param[in] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,n) !> The unitary m-by-n matrix Q. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of the array Q. ldq >= m. !> \endverbatim !> !> \param[out] u !> \verbatim !> u is COMPLEX array, dimension (m) !> The generated vector such that Q'*u = 0 and norm(u) = 1. !> \endverbatim !> !> \ingroup qrdecomp subroutine cgqvec(m,n,Q,ldq,u) use iso_fortran_env use qrupdate_blas use qrupdate_error integer, intent(in) :: m, n, ldq complex(real32), intent(in) :: Q(ldq,*) complex(real32), intent(out) :: u(*) external caxpy,scnrm2,csscal real(real32) scnrm2,r complex(real32) rc integer info,i,j ! quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1e0 do i = 2,m u(i) = 0e0 end do return end if ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('CGQVEC',info) return end if j = 1 r = 0e0 do while( r .eq. 0e0 ) ! probe j-th canonical unit vector. do i = 1,m u(i) = 0e0 end do u(j) = 1e0 ! form u - Q*Q'*u do i = 1,n call qrupdate_cdotc(rc, m,Q(1,i),1,u,1) call caxpy(m,-rc,Q(1,i),1,u,1) end do r = scnrm2(m,u,1) if (r == 0e0) then j = j + 1 if (j > n) then ! this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in CGQVEC' end if end if end do call csscal(m,1e0/r,u,1) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/clu1up.f90000066400000000000000000000115001522610125300234270ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates an LU factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine clu1up(m,n,L,ldl,R,ldr,u,v) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> complex L(ldl,*), R(ldr,*), u(*), v(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CLU1UP updates an LU factorization after rank-1 modification. !> Given an m-by-k lower-triangular matrix L with unit diagonal and !> a k-by-n upper-trapezoidal matrix R, where k = min(m,n), this !> CLU1UP updates L -> L1 and R -> R1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, and !> L1*R1 = L*R + u*v', where v' denotes the conjugate transpose of !> v. !> !> The update is performed using the Bennett algorithm with !> column-major access, which processes the leading k-by-k block !> first and then finishes the trailing part of R if needed. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is COMPLEX array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX array, dimension (m) !> On entry, the left m-vector defining the rank-1 !> modification. On exit, if k < m, u is destroyed; !> otherwise, u contains the updated vector. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is COMPLEX array, dimension (n) !> On entry, the right n-vector defining the rank-1 !> modification. On exit, v is destroyed. !> \endverbatim !> !> \ingroup ludecomp subroutine clu1up(m,n,L,ldl,R,ldr,u,v) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr complex(real32), intent(inout) :: L(ldl,*) complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(inout) :: u(*) complex(real32), intent(inout) :: v(*) complex(real32) ui,vi integer k,info,i,j ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('CLU1UP',info) return end if ! The Bennett algorithm, modified for column-major access. ! The leading part. do i = 1,k ! prefetch ui = u(i) vi = v(i) ! delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do ! diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) ! L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do ! Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/clup1up.f90000066400000000000000000000156431522610125300236230ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a row-pivoted LU factorization after rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine clup1up(m,n,L,ldl,R,ldr,p,u,v,w) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> integer p(*) !> complex L(ldl,*), R(ldr,*), u(*), v(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CLUP1UP updates a row-pivoted LU factorization after rank-1 !> modification. Given an m-by-k lower-triangular matrix L with !> unit diagonal, a k-by-n upper-trapezoidal matrix R, and a !> permutation vector p, where k = min(m,n), CLUP1UP !> updates L -> L1, R -> R1 and p -> p1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, p1 a permutation, !> and P1'*L1*R1 = P'*L*R + u*v', where v' denotes the conjugate !> transpose of v and P is the permutation matrix corresponding !> to p. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is COMPLEX array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in] p !> \verbatim !> p is INTEGER array, dimension (m) !> The permutation vector representing the row pivoting. !> On exit, p is updated to reflect the new pivoting. !> \endverbatim !> !> \param[in] u !> \verbatim !> u is COMPLEX array, dimension (m) !> The left m-vector defining the rank-1 modification. !> \endverbatim !> !> \param[in] v !> \verbatim !> v is COMPLEX array, dimension (n) !> The right n-vector defining the rank-1 modification. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX array, dimension (m) !> Workspace vector used during the update computation. !> \endverbatim !> !> \ingroup ludecomp subroutine clup1up(m,n,L,ldl,R,ldr,p,u,v,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr integer, intent(inout) :: p(*) complex(real32), intent(inout) :: L(ldl,*) complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(in) :: u(*) complex(real32), intent(in) :: v(*) complex(real32), intent(out) :: w(*) complex(real32) one,tmp real(real32) tau parameter (one = 1e0, tau = 1e-1) integer k,info,i,j,itmp external ccopy,caxpy,ctrsv,cgeru,cgemv,cswap ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('CLUP1UP',info) return end if ! form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call ctrsv('L','N','U',k,L,ldl,w,1) ! if m > k = n, subtract the trailing part. if (m > k) then call cgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if ! work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then ! need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call cswap(m-j+1,L(j,j),1,L(j,j+1),1) call cswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call cswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call caxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call caxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) ! update w w(j) = w(j) - tmp*w(j+1) end if ! eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 ! update R. call caxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) ! update L. call caxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! add a multiple of v to R call caxpy(n,w(1),v,1,R(1,1),ldr) ! forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then ! need pivoting. swap j and j+1 ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call cswap(m-j+1,L(j,j),1,L(j,j+1),1) call cswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call cswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call caxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call caxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if ! eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) ! update R. R(j+1,j) = 0e0 call caxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) ! update L. call caxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! if m > k = n, complete the update by updating the lower part of L. if (m > k) then call ccopy(k,v,1,w,1) call ctrsv('U','T','N',k,R,ldr,w,1) call cgeru(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqhqr.f90000066400000000000000000000074651522610125300233530ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Reduces an upper Hessenberg matrix to upper trapezoidal form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqhqr(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> complex R(ldr,*), s(*) !> real c(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQHQR reduces an m-by-n upper Hessenberg matrix R to upper !> trapezoidal form. Given an m-by-n upper Hessenberg matrix R, !> CQHQR applies min(m-1,n) Givens rotations from the !> left to eliminate the subdiagonal elements, producing an upper !> trapezoidal matrix. !> !> On exit, c contains the cosine parts and s contains the sine !> parts of the Givens rotations used in the reduction. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper Hessenberg matrix R. On exit, the !> updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= m. !> \endverbatim !> !> \param[out] c !> \verbatim !> c is REAL array, dimension (min(m-1,n)) !> On exit, the cosine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \param[out] s !> \verbatim !> s is COMPLEX array, dimension (min(m-1,n)) !> On exit, the sine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqhqr(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr complex(real32), intent(inout) :: R(ldr,*) real(real32), intent(out) :: c(*) complex(real32), intent(out) :: s(*) external clartg complex(real32) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('CQHQR',info) return end if do i = 1,n ! apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - conjg(s(j))*t end do if (ii < m) then ! generate next rotation call clartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0e0 else R(ii,i) = t end if end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqr1up.f90000066400000000000000000000131121522610125300234320ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqr1up(m,n,k,Q,ldq,R,ldr,u,v,w,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> complex R(ldr,*) !> complex u(*) !> complex v(*) !> complex w(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQR1UP updates a QR factorization after rank-1 modification i.e., !> given a m-by-k unitary Q and m-by-n upper trapezoidal R, an m-vector !> u and n-vector v, CQR1UP updates Q -> Q1 and R -> R1 so that !> Q1*R1 = Q*R + u*v', and Q1 is again unitary and R1 upper trapezoidal. !> (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n < m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,*) !> On entry, the upper trapezoidal m-by-n matrix R. On !> exit, the updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX array, dimension (*) !> On entry, the left m-vector. On exit, if k < m, !> u is destroyed. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is COMPLEX array, dimension (*) !> On entry, the right n-vector. On exit, v is !> destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX array, dimension (*) !> A workspace vector of size k. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (*) !> A real workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqr1up(m,n,k,Q,ldq,R,ldr,u,v,w,rw) use iso_fortran_env use qrupdate_blas use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr complex(real32), intent(inout) :: Q(ldq,*) complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(inout) :: u(*) complex(real32), intent(inout) :: v(*) complex(real32), intent(out) :: w(*) real(real32), intent(out) :: rw(*) external cch1up, cqrqh,cqhqr,cqrot,cqrtv1,caxcpy external caxpy,scnrm2,slamch,csscal,crot real(real32) scnrm2,slamch,ru,ruu integer info,i logical full ! quick return if possible. if (k == 0 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call qrupdate_xerror('CQR1UP',info) return end if full = k == m ru = 1.0 ! in the non-full case, we shall need the norm of u. if (.not.full) ru = scnrm2(m,u,1) ! form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k call qrupdate_cdotc(w(i), m,Q(1,i),1,u,1) if (.not.full) call caxpy(m,-w(i),Q(1,i),1,u,1) end do ! generate rotations to eliminate Q'*u. call cqrtv1(k,w,rw) ! apply rotations to R. call cqrqh(k,n,R,ldr,rw,w(2)) ! apply rotations to Q. call cqrot('B',m,k,Q,ldq,rw,w(2)) ! update the first row of R. call caxcpy(n,w(1),v,1,R(1,1),ldr) ! retriangularize R. call cqhqr(k,n,R,ldr,rw,w) ! apply rotations to Q. call cqrot('F',m,min(k,n+1),Q,ldq,rw,w) ! in the full case, we're finished if (full) return ! compute relative residual norm ruu = scnrm2(m,u,1) ru = ru * slamch('e') if (ruu <= ru) return ! update the orthogonal basis. call csscal(n,ruu,v,1) call csscal(m,1e0/ruu,u,1) call cch1up(n,R,ldr,v,rw) do i = 1,n call crot(m,Q(1,i),1,u,1,rw(i),conjg(v(i))) end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrdec.f90000066400000000000000000000103321522610125300234610ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrdec(m,n,k,Q,ldq,R,ldr,j,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> complex R(ldr,*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRDEC updates a QR factorization after deleting a column. i.e., !> given an m-by-k unitary matrix Q, an k-by-n upper trapezoidal matrix !> R and index j in the range 1:n+1, CQRDEC updates the matrix !> Q -> Q1 and R -> R1 so that Q1 remains unitary, R1 is upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], where A = Q*R. !> (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> (full Q) or k = n < m (economical form, basis dimension will !> decrease). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted column in R. 1 <= j <= n. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (*) !> A real workspace vector of size k-j. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqrdec(m,n,k,Q,ldq,R,ldr,j,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j complex(real32), intent(inout) :: Q(ldq,*) complex(real32), intent(inout) :: R(ldr,*) real(real32), intent(out) :: rw(*) external ccopy,cqhqr,cqrot integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('CQRDEC',info) return end if ! delete the j-th column. do i = j,n-1 call ccopy(k,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < k) then call cqhqr(k+1-j,n-j,R(j,j),ldr,rw,R(1,n)) ! apply rotations to Q. call cqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,rw,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrder.f90000066400000000000000000000102051522610125300234770ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrder(m,n,Q,ldq,R,ldr,j,w,rw) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> complex R(ldr,*) !> complex w(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRDER updates a QR factorization after deleting a row. i.e., given !> an m-by-m unitary matrix Q, an m-by-n upper trapezoidal matrix R and !> index j in the range 1:m, CQRDER updates Q ->Q1 and an R -> !> R1 so that Q1 is again unitary, R1 upper trapezoidal, and Q1*R1 = !> [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the unitary matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row. 1 <= j <= m. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX array, dimension (*) !> A workspace vector of size m. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (*) !> A real workspace vector of size m. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqrder(m,n,Q,ldq,R,ldr,j,w,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr complex(real32), intent(inout) :: Q(ldq,*) complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(out) :: w(*) real(real32), intent(out) :: rw(*) external ccopy,cqrtv1,cqrot,cqrqh integer info,i,k ! quick return if possible. if (m == 1) return ! check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call qrupdate_xerror('CQRDER',info) return end if ! eliminate Q(j,2:m). do k = 1,m w(k) = conjg(Q(j,k)) end do call cqrtv1(m,w,rw) ! apply rotations to Q. call cqrot('B',m,m,Q,ldq,rw,w(2)) ! form Q1. do k = 1,m-1 if (j > 1) call ccopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call ccopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do ! apply rotations to R. call cqrqh(m,n,R,ldr,rw,w(2)) ! form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrinc.f90000066400000000000000000000132701522610125300235030ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrinc(m,n,k,Q,ldq,R,ldr,j,x,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> complex R(ldr,*) !> complex x(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRINC updates a QR factorization after inserting a new column. i.e., !> given an m-by-k unitary matrix Q, an m-by-n upper trapezoidal matrix !> R and index j in the range 1:n+1, CQRINC updates the matrix !> Q -> Q1 and R -> R1 so that Q1 is again unitary, R1 upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], where A = Q*R. !> (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n <= m (economical form, !> basis dimension will increase). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= min(m,n+1). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new column in R1. 1 <= j <= n+1. !> \endverbatim !> !> \param[in] x !> \verbatim !> x is COMPLEX array, dimension (*) !> The column being inserted. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (*) !> A real workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqrinc(m,n,k,Q,ldq,R,ldr,j,x,rw) use iso_fortran_env use qrupdate_blas use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j complex(real32), intent(inout) :: Q(ldq,*), R(ldr,*) complex(real32), intent(in) :: x(*) real(real32), intent(out) :: rw(*) external cgqvec, cqrtv1,cqrqh,cqrot external ccopy,caxpy,csscal,scnrm2 real(real32) scnrm2,rx integer info,i,k1 logical full ! quick return if possible. if (m == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('CQRINC',info) return end if full = k == m ! insert empty column at j-th position do i = n,j,-1 call ccopy(k,R(1,i),1,R(1,i+1),1) end do ! insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k call qrupdate_cdotc(R(i,j), m,Q(1,i),1,x,1) end do else k1 = k + 1 ! zero last row of R do i = 1,n+1 R(k1,i) = 0e0 end do call ccopy(m,x,1,Q(1,k1),1) do i = 1,k call qrupdate_cdotc(R(i,j), m,Q(1,i),1,Q(1,k1),1) call caxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do ! get norm of the inserted column rx = scnrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0e0) then ! in the rare case when rx is exact zero, we still need to provide ! a valid orthogonal unit vector. The details are boring, so handle ! that elsewhere. call cgqvec(m,k,Q,ldq,Q(1,k1)) else ! otherwise, just normalize the added column. call csscal(m,1e0/rx,Q(1,k1),1) end if end if ! maybe we're finished. if (j > k) return ! eliminate the spike. call cqrtv1(k1+1-j,R(j,j),rw) ! apply rotations to R(j:k,j:n). if (j <= n) call cqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) ! apply rotations to Q(:,j:k). call cqrot('B',m,k1+1-j,Q(1,j),ldq,rw,R(j+1,j)) ! zero spike. do i = j+1,k1 R(i,j) = 0e0 end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrinr.f90000066400000000000000000000107051522610125300235220ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrinr(m,n,Q,ldq,R,ldr,j,x,rw) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> complex R(ldr,*) !> complex x(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRINR updates a QR factorization after inserting a new row. i.e., !> given an m-by-m unitary matrix Q, an m-by-n upper trapezoidal matrix !> R and index j in the range 1:m+1, CQRINR updates Q -> Q1 and !> R -> R1 so that Q1 is again unitary, R1 upper trapezoidal, and Q1*R1 !> = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the unitary matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m+1. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new row in R1. 1 <= j <= m+1. !> \endverbatim !> !> \param[in,out] x !> \verbatim !> x is COMPLEX array, dimension (*) !> On entry, the row being added. On exit, x is !> destroyed. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (*) !> A real workspace vector of size min(m,n). !> \endverbatim !> !> \ingroup qrdecomp subroutine cqrinr(m,n,Q,ldq,R,ldr,j,x,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr complex(real32), intent(inout) :: Q(ldq,*) complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(inout) :: x(*) real(real32), intent(out) :: rw(*) external ccopy,cqhqr,cqrot integer info,i,k ! check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call qrupdate_xerror('CQRINR',info) return end if ! permute the columns of Q1 and rows of R1 so that c the new row ends ! up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call ccopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0e0 if (j <= m) then call ccopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do ! set up the 1st column do i = 1,j-1 Q(i,1) = 0e0 end do Q(j,1) = 1e0 do i = j+1,m+1 Q(i,1) = 0e0 end do ! set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0e0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do ! retriangularize R call cqhqr(m+1,n,R,ldr,rw,x) ! apply rotations to Q call cqrot('F',m+1,min(m,n)+1,Q,ldq,rw,x) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrot.f90000066400000000000000000000076731522610125300233660ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Applies a sequence of Givens rotations from the right to a matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrot(dir,m,n,Q,ldq,c,s) !> !> .. Scalar Arguments .. !> character dir !> integer m, n, ldq !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> real c(*) !> complex s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQROT applies a sequence of Givens rotations from the right !> side to an m-by-n matrix Q. Given a direction indicator !> dir, the rotation cosine and sine vectors c and s, CQROT !> applies the rotations to Q, updating it in place. If dir !> is 'F' (forward), rotations are applied from the first to !> the last; if dir is 'B' (backward), from the last to the !> first. !> \endverbatim !> !> \param[in] dir !> \verbatim !> dir is CHARACTER !> If 'B' or 'b', rotations are applied backwards !> (from the last to the first). If 'F' or 'f', !> rotations are applied forwards (from the first to !> the last). !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the matrix Q. On exit, the updated !> matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is REAL array, dimension (*) !> The rotation cosines. Must contain at least !> n-1 elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is COMPLEX array, dimension (*) !> The rotation sines. Must contain at least !> n-1 elements. !> \endverbatim !> !> \ingroup givens subroutine cqrot(dir,m,n,Q,ldq,c,s) use iso_fortran_env use qrupdate_error use qrupdate_blas character, intent(in) :: dir integer, intent(in) :: m, n, ldq complex(real32), intent(inout) :: Q(ldq,*) complex(real32), intent(in) :: s(*) real(real32), intent(in) :: c(*) external crot logical fwd integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. n == 1) return ! check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call qrupdate_xerror('CQROT',info) return end if if (fwd) then do i = 1,n-1 call crot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do else do i = n-1,1,-1 call crot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrqh.f90000066400000000000000000000067631522610125300233530ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Converts an upper trapezoidal matrix to upper Hessenberg form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrqh(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> complex R(ldr,*), s(*) !> real c(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRQH brings an m-by-n upper trapezoidal matrix R into upper !> Hessenberg form. Given an m-by-n upper trapezoidal matrix R, !> CQRQH applies min(m-1,n) inverse Givens rotations !> from the right to introduce subdiagonal elements, producing an !> upper Hessenberg matrix. !> !> On exit, c contains the cosine parts and s contains the sine !> parts of the Givens rotations used in the transformation. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,n) !> On entry, the upper trapezoidal matrix R. On exit, the !> upper Hessenberg matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is REAL array, dimension (min(m-1,n)) !> The cosine parts of the Givens rotations. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is COMPLEX array, dimension (min(m-1,n)) !> The sine parts of the Givens rotations. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqrqh(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(in) :: s(*) real(real32), intent(in) :: c(*) complex(real32) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('CQRQH',info) return end if do i = 1,n ! apply stored rotations, column-wise ii = min(m-1,i) t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - conjg(s(j))*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrshc.f90000066400000000000000000000126701522610125300235120ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a circular shift of columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrshc(m,n,k,Q,ldq,R,ldr,i,j,w,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, i, j !> .. !> .. Array Arguments .. !> complex Q(ldq,*) !> complex R(ldr,*) !> complex w(*) !> real rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRSHC updates a QR factorization after circular shift of columns. !> i.e., given an m-by-k unitary matrix Q, an k-by-n upper trapezoidal !> matrix R and index j in the range 1:n+1, CQRSHC updates the !> matrix Q -> Q1 and R -> R1 so that Q1 is again unitary, R1 upper !> trapezoidal, and Q1*R1 = A(:,p), where A = Q*R and p is the !> permutation [1:i-1,shift(i:j,-1),j+1:n] if i < j or !> [1:j-1,shift(j:i,+1),i+1:n] if j < i. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q1, and rows of R1. Must be !> either k = m (full Q) or k = n <= m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range (see above). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range (see above). !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX array, dimension (*) !> A workspace vector of size k. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is REAL array, dimension (*) !> A real workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine cqrshc(m,n,k,Q,ldq,R,ldr,i,j,w,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, i, j complex(real32), intent(inout) :: Q(ldq,*) complex(real32), intent(inout) :: R(ldr,*) complex(real32), intent(out) :: w(*) real(real32), intent(out) :: rw(*) external ccopy,cqrtv1,cqrqh,cqhqr,cqrot integer info,jj,kk,l ! quick return if possible. if (m == 0 .or. n == 1) return info = 0 ! check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call qrupdate_xerror('CQRSHC',info) return end if if (i < j) then ! shift columns call ccopy(k,R(1,i),1,w,1) do l = i,j-1 call ccopy(k,R(1,l+1),1,R(1,l),1) end do call ccopy(k,w,1,R(1,j),1) ! retriangularize if (i < k) then kk = min(k,j) call cqhqr(kk+1-i,n+1-i,R(i,i),ldr,rw,w) ! apply rotations to Q. call cqrot('F',m,kk+1-i,Q(1,i),ldq,rw,w) end if else if (j < i) then ! shift columns call ccopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call ccopy(k,R(1,l-1),1,R(1,l),1) end do call ccopy(k,w,1,R(1,j),1) ! retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) ! eliminate the introduced spike. call cqrtv1(kk+1-j,R(j,j),rw) ! apply rotations to R call cqrqh(kk+1-j,n-j,R(j,jj),ldr,rw,R(j+1,j)) ! apply rotations to Q call cqrot('B',m,kk+1-j,Q(1,j),ldq,rw,R(j+1,j)) ! zero spike. do l = j+1,kk R(l,j) = 0e0 end do end if end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/cqrtv1.f90000066400000000000000000000054161522610125300234470ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates Givens rotations to eliminate all but the first element of a vector. !> !> \par Definition: ! ============= !> \verbatim !> subroutine cqrtv1(n,u,w) !> !> .. Scalar Arguments .. !> integer n !> .. !> .. Array Arguments .. !> complex u(*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> CQRTV1 generates a sequence of n-1 Givens rotations that !> eliminate all but the first element of a complex vector u. !> On entry, u contains the vector to be reduced. On exit, !> u(1) contains the resulting element, u(2:n) contains the !> rotation sines, and w contains the rotation cosines. !> !> The rotations are generated from the bottom up, so that the !> first rotation eliminates u(n), the second eliminates u(n-1), !> and so on. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The length of the vector u. If n <= 0, the subroutine !> returns immediately without modification. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX array, dimension (n) !> On entry, the vector to be reduced. On exit, u(1) !> contains the remaining element, and u(2:n) contains !> the sine parts of the Givens rotations. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations. !> \endverbatim !> !> \ingroup givens subroutine cqrtv1(n,u,w) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: u(*) real(real32), intent(out) :: w(*) external clartg complex(real32) rr,t integer i ! quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call clartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dch1dn.f90000066400000000000000000000106741522610125300233720ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Downdates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dch1dn(n,R,ldr,u,w,info) !> !> .. Scalar Arguments .. !> integer n, ldr, info !> .. !> .. Array Arguments .. !> double precision R(ldr,*), u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DCH1DN downdates the Cholesky factorization of a symmetric !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R.'*R, where R.' denotes the transpose of R, DCH1DN !> downdates R -> R1 so that R1.'*R1 = A - u*u.', where u is a !> given vector. !> !> The downdate is performed by applying a sequence of hyperbolic !> rotations to restore the upper triangular structure of R. On !> exit, u contains the rotation sines and w contains the rotation !> cosines used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A - u*u.'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (n) !> On entry, the vector determining the rank-1 downdate. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n) !> On exit, w contains the cosine parts of the !> rotations used to transform R to R1. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> \endverbatim !> !> \ingroup choldecomp subroutine dch1dn(n,R,ldr,u,w,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr real(real64), intent(inout) :: R(ldr,*) real(real64), intent(inout) :: u(*) real(real64), intent(out) :: w(*) integer, intent(out) :: info external dtrsv,dlartg,dnrm2 real(real64) dnrm2,rho,rr,ui,t integer i,j ! quick return if possible. if (n == 0) return ! check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call qrupdate_xerror('DCH1DN',-info) return end if ! check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do ! form R' \ u call dtrsv('U','T','N',n,R,ldr,u,1) rho = dnrm2(n,u,1) ! check positive definiteness rho = 1 - rho**2 if (rho <= 0d0) goto 10 rho = sqrt(rho) ! eliminate R' \ u do i = n,1,-1 ui = u(i) ! generate next rotation call dlartg(rho,ui,w(i),u(i),rr) rho = rr end do ! apply rotations do i = n,1,-1 ui = 0d0 do j = i,1,-1 t = w(j)*ui + u(j)*R(j,i) R(j,i) = w(j)*R(j,i) - u(j)*ui ui = t end do end do ! normal return return ! error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dch1up.f90000066400000000000000000000067021522610125300234120ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dch1up(n,R,ldr,u,w) !> !> .. Scalar Arguments .. !> integer n, ldr !> .. !> .. Array Arguments .. !> double precision R(ldr,*), u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DCH1UP updates the Cholesky factorization of a symmetric !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R.'*R, where R.' denotes the transpose of R, DCH1UP !> updates R -> R1 so that R1.'*R1 = A + u*u.', where u is a given !> vector. !> !> The update is performed by applying a sequence of Givens rotations !> to restore the upper triangular structure of R. On exit, u !> contains the rotation sines and w contains the rotation cosines !> used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A + u*u.'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (n) !> On entry, the vector determining the rank-1 update. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations used to transform R to R1. !> \endverbatim !> !> \ingroup choldecomp subroutine dch1up(n,R,ldr,u,w) use iso_fortran_env integer, intent(in) :: n, ldr real(real64), intent(inout) :: R(ldr,*) real(real64), intent(inout) :: u(*) real(real64), intent(out) :: w(*) external dlartg real(real64) rr,ui,t integer i,j do i = 1,n ! apply stored rotations, column-wise ui = u(i) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - u(j)*R(j,i) R(j,i) = t end do ! generate next rotation call dlartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dchdex.f90000066400000000000000000000062061522610125300234640ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after deleting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dchdex(n,R,ldr,j,w) !> !> .. Scalar Arguments .. !> integer n, ldr, j !> .. !> .. Array Arguments .. !> double precision R(ldr,*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DCHDEX updates the Cholesky factorization of a symmetric !> positive definite matrix A after deleting a row/column. !> Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R.'*R, where R.' denotes the !> transpose of R, DCHDEX updates R -> R1 so that !> R1.'*R1 = A(jj,jj), where jj = [1:j-1, j+1:n+1]. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(jj,jj). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row/column. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n) !> A workspace vector. !> \endverbatim !> !> \ingroup choldecomp subroutine dchdex(n,R,ldr,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, j real(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: w(*) integer info,i external dcopy,dqhqr ! quick return if possible. if (n == 1) return ! check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call qrupdate_xerror('DCHDEX',info) return end if ! delete the j-th column. do i = j,n-1 call dcopy(n,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < n) then call dqhqr(n+1-j,n-j,R(j,j),ldr,w,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dchinx.f90000066400000000000000000000112241522610125300234760ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after inserting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dchinx(n,R,ldr,j,u,w,info) !> !> .. Scalar Arguments .. !> integer n, j, ldr, info !> .. !> .. Array Arguments .. !> double precision R(ldr,*), u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DCHINX updates the Cholesky factorization of a symmetric !> positive definite matrix A after inserting a row and column. !> Given an upper triangular matrix R that is a Cholesky factor of !> A, i.e., A = R.'*R, where R.' denotes the transpose of R, this !> DCHINX updates R -> R1 so that R1.'*R1 = A1, where !> A1(jj,jj) = A, A1(j,:) = u.', A1(:,j) = u, and !> jj = [1:j-1, j+1:n+1]. !> !> On exit, u is destroyed and R is extended by one row and column. !> The insertion is performed by first solving R.'*u = v, checking !> positive definiteness, and then retriangularizing. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n+1) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the inserted row and column. !> 1 <= j <= n+1. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (n+1) !> On entry, the vector defining the inserted row/column. !> On exit, u is destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n+1) !> Workspace vector used during the retriangularization. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> \endverbatim !> !> \ingroup choldecomp subroutine dchinx(n,R,ldr,j,u,w,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, j, ldr integer, intent(out) :: info real(real64), intent(inout) :: R(ldr,*) real(real64), intent(inout) :: u(*) real(real64), intent(out) :: w(*) external dcopy,dnrm2,dtrsv,dqrtv1,dqrqh real(real64) dnrm2,rho,t integer i ! check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call qrupdate_xerror('DCHINX',-info) return end if ! shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do ! check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do ! form R' \ u call dtrsv('U','T','N',n,R,ldr,u,1) rho = dnrm2(n,u,1) ! check positive definiteness. rho = t - rho**2 if (rho <= 0d0) goto 10 ! shift columns do i = n,j,-1 call dcopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0d0 end do call dcopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) ! retriangularize if (j < n+1) then ! eliminate the introduced spike. call dqrtv1(n+2-j,R(j,j),w) ! apply rotations to R call dqrqh(n+2-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) ! zero spike. do i = j+1,n+1 R(i,j) = 0d0 end do end if ! normal return. return ! error returns. 10 info = 1 return 20 info = 2 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dchshx.f90000066400000000000000000000101301522610125300234750ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a symmetric shift of rows and columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dchshx(n,R,ldr,i,j,w) !> !> .. Scalar Arguments .. !> integer n, ldr, i, j !> .. !> .. Array Arguments .. !> double precision R(ldr,*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DCHSHX updates the Cholesky factorization of a symmetric !> positive definite matrix A after a symmetric shift of rows and !> columns. Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R.'*R, where R.' denotes the transpose !> of R, DCHSHX updates R -> R1 so that !> R1.'*R1 = A(p,p), where p is the permutation !> [1:i-1, shift(i:j,-1), j+1:n] if i < j, or !> [1:j-1, shift(j:i,+1), i+1:n] if j < i. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(p,p). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range of the shift. !> 1 <= i <= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range of the shift. !> 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (2*n) !> Workspace vector used during the retriangularization. !> \endverbatim !> !> \ingroup choldecomp subroutine dchshx(n,R,ldr,i,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, i, j real(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: w(*) external dcopy,dqrtv1,dqrqh,dqhqr integer info,l ! quick return if possible. if (n == 0 .or. n == 1) return info = 0 ! check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call qrupdate_xerror('DCHSHX',info) return end if if (i < j) then ! shift columns call dcopy(n,R(1,i),1,w,1) do l = i,j-1 call dcopy(n,R(1,l+1),1,R(1,l),1) end do call dcopy(n,w,1,R(1,j),1) ! retriangularize call dqhqr(n+1-i,n+1-i,R(i,i),ldr,w(n+1),w) else if (j < i) then ! shift columns call dcopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call dcopy(n,R(1,l-1),1,R(1,l),1) end do call dcopy(n,w,1,R(1,j),1) ! eliminate the introduced spike. call dqrtv1(n+1-j,R(j,j),w(n+1)) ! apply rotations to R call dqrqh(n+1-j,n-j,R(j,j+1),ldr,w(n+1),R(j+1,j)) ! zero spike. do l = j+1,n R(l,j) = 0d0 end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dgqvec.f90000066400000000000000000000074731522610125300235050ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates a unit vector orthogonal to the column space of a unitary matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dgqvec(m,n,Q,ldq,u) !> !> .. Scalar Arguments .. !> integer m, n, ldq !> .. !> .. Array Arguments .. !> double precision Q(ldq,*), u(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DGQVEC generates a vector u in the orthogonal complement of the !> column space of an orthogonal matrix Q. Given an m-by-n !> orthogonal matrix Q with n < m, DGQVEC generates a !> vector u of length m such that Q.'*u = 0 and norm(u) = 1, where !> Q.' denotes the transpose of Q. !> !> The algorithm projects canonical unit vectors onto the orthogonal !> complement of Q's column space until a nonzero result is found. !> If n = 0, the first canonical unit vector is returned. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0 and !> n < m. !> \endverbatim !> !> \param[in] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,n) !> The orthogonal m-by-n matrix Q. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of the array Q. ldq >= m. !> \endverbatim !> !> \param[out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (m) !> The generated vector such that Q.'*u = 0 and norm(u) = 1. !> \endverbatim !> !> \ingroup qrdecomp subroutine dgqvec(m,n,Q,ldq,u) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldq real(real64), intent(in) :: Q(ldq,*) real(real64), intent(out) :: u(*) external ddot,daxpy,dnrm2,dscal real(real64) ddot,dnrm2,r integer info,i,j ! quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1d0 do i = 2,m u(i) = 0d0 end do return end if ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('DGQVEC',info) return end if j = 1 r = 0d0 do while ( r .eq. 0d0 ) ! probe j-th canonical unit vector. do i = 1,m u(i) = 0d0 end do u(j) = 1d0 ! form u - Q*Q'*u do i = 1,n r = ddot(m,Q(1,i),1,u,1) call daxpy(m,-r,Q(1,i),1,u,1) end do r = dnrm2(m,u,1) if (r == 0d0) then j = j + 1 if (j > n) then ! this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in DGQVEC' end if end if end do call dscal(m,1d0/r,u,1) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dlu1up.f90000066400000000000000000000113441522610125300234360ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates an LU factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dlu1up(m,n,L,ldl,R,ldr,u,v) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> double precision L(ldl,*), R(ldr,*), u(*), v(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DLU1UP updates an LU factorization after rank-1 modification. !> Given an m-by-k lower-triangular matrix L with unit diagonal and !> a k-by-n upper-trapezoidal matrix R, where k = min(m,n), this !> DLU1UP updates L -> L1 and R -> R1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, and !> L1*R1 = L*R + u*v.', where v.' denotes the transpose of v. !> !> The update is performed using the Bennett algorithm with !> column-major access, which processes the leading k-by-k block !> first and then finishes the trailing part of R if needed. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is DOUBLE PRECISION array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (m) !> On entry, the left m-vector defining the rank-1 !> modification. On exit, if k < m, u is destroyed; !> otherwise, u contains the updated vector. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is DOUBLE PRECISION array, dimension (n) !> On entry, the right n-vector defining the rank-1 !> modification. On exit, v is destroyed. !> \endverbatim !> !> \ingroup ludecomp subroutine dlu1up(m,n,L,ldl,R,ldr,u,v) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr real(real64), intent(inout) :: L(ldl,*), R(ldr,*), u(*), v(*) real(real64) ui,vi integer k,info,i,j ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('DLU1UP',info) return end if ! The Bennett algorithm, modified for column-major access. ! The leading part. do i = 1,k ! prefetch ui = u(i) vi = v(i) ! delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do ! diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) ! L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do ! Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dlup1up.f90000066400000000000000000000156451522610125300236260ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a row-pivoted LU factorization after rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dlup1up(m,n,L,ldl,R,ldr,p,u,v,w) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> integer p(*) !> double precision L(ldl,*), R(ldr,*), u(*), v(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DLUP1UP updates a row-pivoted LU factorization after rank-1 !> modification. Given an m-by-k lower-triangular matrix L with !> unit diagonal, a k-by-n upper-trapezoidal matrix R, and a !> permutation vector p, where k = min(m,n), DLUP1UP !> updates L -> L1, R -> R1 and p -> p1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, p1 a permutation, !> and P1.'*L1*R1 = P.'*L*R + u*v.', where v.' denotes the !> transpose of v and P is the permutation matrix corresponding !> to p. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is DOUBLE PRECISION array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in] p !> \verbatim !> p is INTEGER array, dimension (m) !> The permutation vector representing the row pivoting. !> On exit, p is updated to reflect the new pivoting. !> \endverbatim !> !> \param[in] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (m) !> The left m-vector defining the rank-1 modification. !> \endverbatim !> !> \param[in] v !> \verbatim !> v is DOUBLE PRECISION array, dimension (n) !> The right n-vector defining the rank-1 modification. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (m) !> Workspace vector used during the update computation. !> \endverbatim !> !> \ingroup ludecomp subroutine dlup1up(m,n,L,ldl,R,ldr,p,u,v,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr integer, intent(inout) :: p(*) real(real64), intent(inout) :: L(ldl,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(in) :: u(*) real(real64), intent(in) :: v(*) real(real64), intent(out) :: w(*) real(real64) one,tau,tmp parameter (one = 1d0, tau = 1d-1) integer k,info,i,j,itmp external dcopy,daxpy,dtrsv,dger,dgemv,dswap ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('DLUP1UP',info) return end if ! form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call dtrsv('L','N','U',k,L,ldl,w,1) ! if m > k = n, subtract the trailing part. if (m > k) then call dgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if ! work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then ! need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call dswap(m-j+1,L(j,j),1,L(j,j+1),1) call dswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call dswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call daxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call daxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) ! update w w(j) = w(j) - tmp*w(j+1) end if ! eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 ! update R. call daxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) ! update L. call daxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! add a multiple of v to R call daxpy(n,w(1),v,1,R(1,1),ldr) ! forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then ! need pivoting. swap j and j+1 ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call dswap(m-j+1,L(j,j),1,L(j,j+1),1) call dswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call dswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call daxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call daxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if ! eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) ! update R. R(j+1,j) = 0d0 call daxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) ! update L. call daxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! if m > k = n, complete the update by updating the lower part of L. if (m > k) then call dcopy(k,v,1,w,1) call dtrsv('U','T','N',k,R,ldr,w,1) call dger(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqhqr.f90000066400000000000000000000074501522610125300233460ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Reduces an upper Hessenberg matrix to upper trapezoidal form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqhqr(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> double precision R(ldr,*), c(*), s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQHQR reduces an m-by-n upper Hessenberg matrix R to upper !> trapezoidal form. Given an m-by-n upper Hessenberg matrix R, !> DQHQR applies min(m-1,n) Givens rotations from the !> left to eliminate the subdiagonal elements, producing an upper !> trapezoidal matrix. !> !> On exit, c contains the cosine parts and s contains the sine !> parts of the Givens rotations used in the reduction. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,n) !> On entry, the upper Hessenberg matrix R. On exit, the !> updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= m. !> \endverbatim !> !> \param[out] c !> \verbatim !> c is DOUBLE PRECISION array, dimension (min(m-1,n)) !> On exit, the cosine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \param[out] s !> \verbatim !> s is DOUBLE PRECISION array, dimension (min(m-1,n)) !> On exit, the sine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqhqr(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr real(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: c(*) real(real64), intent(out) :: s(*) external dlartg real(real64) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('DQHQR',info) return end if do i = 1,n ! apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - s(j)*t end do if (ii < m) then ! generate next rotation call dlartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0d0 else R(ii,i) = t end if end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqr1up.f90000066400000000000000000000125771522610125300234510ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqr1up(m,n,k,Q,ldq,R,ldr,u,v,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision R(ldr,*) !> double precision u(*) !> double precision v(*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQR1UP updates a QR factorization after rank-1 modification i.e., !> given a m-by-k orthogonal Q and m-by-n upper trapezoidal R, an !> m-vector u and n-vector v, DQR1UP updates Q -> Q1 and R -> !> R1 so that Q1*R1 = Q*R + u*v', and Q1 is again orthonormal and R1 !> upper trapezoidal. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n < m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the upper trapezoidal m-by-n matrix R. On !> exit, the updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (*) !> On entry, the left m-vector. On exit, if k < m, !> u is destroyed. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is DOUBLE PRECISION array, dimension (*) !> On entry, the right n-vector. On exit, v is !> destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (*) !> A workspace vector of size 2*k. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqr1up(m,n,k,Q,ldq,R,ldr,u,v,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(inout) :: u(*) real(real64), intent(inout) :: v(*) real(real64), intent(out) :: w(*) external dch1up, dqrqh,dqhqr,dqrot,dqrtv1 external daxpy,ddot,dnrm2,dlamch,dscal,drot real(real64) ddot,dnrm2,dlamch,ru,ruu integer info,i logical full ! quick return if possible. if (k == 0 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call qrupdate_xerror('DQR1UP',info) return end if full = k == m ru = 1.0D0 ! in the non-full case, we shall need the norm of u. if (.not.full) ru = dnrm2(m,u,1) ! form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k w(i) = ddot(m,Q(1,i),1,u,1) if (.not.full) call daxpy(m,-w(i),Q(1,i),1,u,1) end do ! generate rotations to eliminate Q'*u. call dqrtv1(k,w,w(k+1)) ! apply rotations to R. call dqrqh(k,n,R,ldr,w(k+1),w(2)) ! apply rotations to Q. call dqrot('B',m,k,Q,ldq,w(k+1),w(2)) ! update the first row of R. call daxpy(n,w(1),v,1,R(1,1),ldr) ! retriangularize R. call dqhqr(k,n,R,ldr,w(k+1),w) ! apply rotations to Q. call dqrot('F',m,min(k,n+1),Q,ldq,w(k+1),w) ! in the full case, we're finished if (full) return ! compute relative residual norm ruu = dnrm2(m,u,1) ru = ru * dlamch('e') if (ruu <= ru) return ! update the orthogonal basis. call dscal(n,ruu,v,1) call dscal(m,1d0/ruu,u,1) call dch1up(n,R,ldr,v,w(k+1)) do i = 1,n call drot(m,Q(1,i),1,u,1,w(k+i),v(i)) end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrdec.f90000066400000000000000000000103701522610125300234640ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrdec(m,n,k,Q,ldq,R,ldr,j,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision R(ldr,*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRDEC updates a QR factorization after deleting a column. i.e., !> given an m-by-k orthogonal matrix Q, an k-by-n upper trapezoidal !> matrix R and index j in the range 1:n+1, DQRDEC updates the !> matrix Q -> Q1 and R -> R1 so that Q1 remains orthogonal, R1 is upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], where A = Q*R. !> (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n < m (economical form, !> basis dimension will decrease). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted column in R. 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (*) !> A workspace vector of size k-j. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqrdec(m,n,k,Q,ldq,R,ldr,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: w(*) external dcopy,dqhqr,dqrot integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('DQRDEC',info) return end if ! delete the j-th column. do i = j,n-1 call dcopy(k,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < k) then call dqhqr(k+1-j,n-j,R(j,j),ldr,w,R(1,n)) ! apply rotations to Q. call dqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,w,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrder.f90000066400000000000000000000076701522610125300235140ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrder(m,n,Q,ldq,R,ldr,j,w) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision R(ldr,*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRDER updates a QR factorization after deleting a row. i.e., given !> an m-by-m orthogonal matrix Q, an m-by-n upper trapezoidal matrix R !> and index j in the range 1:m, DQRDER updates Q ->Q1 and an R !> -> R1 so that Q1 is again orthogonal, R1 upper trapezoidal, and Q1*R1 !> = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 1. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the orthogonal matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row. 1 <= j <= m. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (*) !> A workspace vector of size 2*m. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqrder(m,n,Q,ldq,R,ldr,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: w(*) external dcopy,dqrtv1,dqrot,dqrqh integer info,i,k ! quick return if possible. if (m == 1) return ! check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call qrupdate_xerror('DQRDER',info) return end if ! eliminate Q(j,2:m). call dcopy(m,Q(j,1),ldq,w,1) call dqrtv1(m,w,w(m+1)) ! apply rotations to Q. call dqrot('B',m,m,Q,ldq,w(m+1),w(2)) ! form Q1. do k = 1,m-1 if (j > 1) call dcopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call dcopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do ! apply rotations to R. call dqrqh(m,n,R,ldr,w(m+1),w(2)) ! form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrinc.f90000066400000000000000000000133061522610125300235040ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrinc(m,n,k,Q,ldq,R,ldr,j,x,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision R(ldr,*) !> double precision x(*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRINC updates a QR factorization after inserting a new column. i.e., !> given an m-by-k orthogonal matrix Q, an m-by-n upper trapezoidal !> matrix R and index j in the range 1:n+1, DQRINC updates the !> matrix Q -> Q1 and R -> R1 so that Q1 is again orthogonal, R1 upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], where A = Q*R. !> (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n <= m (economical form, !> basis dimension will increase). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= min(m,n+1). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new column in R1. 1 <= j <= n+1. !> \endverbatim !> !> \param[in] x !> \verbatim !> x is DOUBLE PRECISION array, dimension (*) !> The column being inserted. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (*) !> A workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqrinc(m,n,k,Q,ldq,R,ldr,j,x,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(in) :: x(*) real(real64), intent(out) :: w(*) external dqrtv1,dqrqh,dqrot,dgqvec external dcopy,ddot,daxpy,dscal,dnrm2 real(real64) ddot,dnrm2,rx integer info,i,k1 logical full ! quick return if possible. if (m == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('DQRINC',info) return end if full = k == m ! insert empty column at j-th position. do i = n,j,-1 call dcopy(k,R(1,i),1,R(1,i+1),1) end do ! insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k R(i,j) = ddot(m,Q(1,i),1,x,1) end do else k1 = k + 1 ! zero last row of R do i = 1,n+1 R(k1,i) = 0d0 end do call dcopy(m,x,1,Q(1,k1),1) do i = 1,k R(i,j) = ddot(m,Q(1,i),1,Q(1,k1),1) call daxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do ! get norm of the inserted column rx = dnrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0d0) then ! in the rare case when rx is exact zero, we still need to provide ! a valid orthogonal unit vector. The details are boring, so handle ! that elsewhere. call dgqvec(m,k,Q,ldq,Q(1,k1)) else ! otherwise, just normalize the added column. call dscal(m,1d0/rx,Q(1,k1),1) end if end if ! maybe we're finished. if (j > k) return ! eliminate the spike. call dqrtv1(k1+1-j,R(j,j),w) ! apply rotations to R(j:k,j:n). if (j <= n) call dqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) ! apply rotations to Q(:,j:k). call dqrot('B',m,k1+1-j,Q(1,j),ldq,w,R(j+1,j)) ! zero spike. do i = j+1,k1 R(i,j) = 0d0 end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrinr.f90000066400000000000000000000107341522610125300235250ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrinr(m,n,Q,ldq,R,ldr,j,x,w) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision R(ldr,*) !> double precision x(*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRINR updates a QR factorization after inserting a new row. i.e., !> given an m-by-m orthogonal matrix Q, an m-by-n upper trapezoidal !> matrix R and index j in the range 1:m+1, DQRINR updates Q -> !> Q1 and R -> R1 so that Q1 is again orthogonal, R1 upper trapezoidal, !> and Q1*R1 = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the orthogonal matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m+1. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new row in R1. 1 <= j <= m+1. !> \endverbatim !> !> \param[in,out] x !> \verbatim !> x is DOUBLE PRECISION array, dimension (*) !> On entry, the row being added. On exit, x is !> destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (*) !> A workspace vector of size min(m,n). !> \endverbatim !> !> \ingroup qrdecomp subroutine dqrinr(m,n,Q,ldq,R,ldr,j,x,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(inout) :: x(*) real(real64), intent(out) :: w(*) external dcopy,dqhqr,dqrot integer info,i,k ! check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call qrupdate_xerror('DQRINR',info) return end if ! permute the columns of Q1 and rows of R1 so that c the new row ends ! up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call dcopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0d0 if (j <= m) then call dcopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do ! set up the 1st column do i = 1,j-1 Q(i,1) = 0d0 end do Q(j,1) = 1d0 do i = j+1,m+1 Q(i,1) = 0d0 end do ! set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0d0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do ! retriangularize R call dqhqr(m+1,n,R,ldr,w,x) ! apply rotations to Q call dqrot('F',m+1,min(m,n)+1,Q,ldq,w,x) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrot.f90000066400000000000000000000077061522610125300233640ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Applies a sequence of Givens rotations from the right to a matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrot(dir,m,n,Q,ldq,c,s) !> !> .. Scalar Arguments .. !> character dir !> integer m, n, ldq !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision c(*) !> double precision s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQROT applies a sequence of Givens rotations from the right !> side to an m-by-n matrix Q. Given a direction indicator !> dir, the rotation cosine and sine vectors c and s, DQROT !> applies the rotations to Q, updating it in place. If dir !> is 'F' (forward), rotations are applied from the first to !> the last; if dir is 'B' (backward), from the last to the !> first. !> \endverbatim !> !> \param[in] dir !> \verbatim !> dir is CHARACTER !> If 'B' or 'b', rotations are applied backwards !> (from the last to the first). If 'F' or 'f', !> rotations are applied forwards (from the first to !> the last). !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the matrix Q. On exit, the updated !> matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is DOUBLE PRECISION array, dimension (*) !> The rotation cosines. Must contain at least n-1 !> elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is DOUBLE PRECISION array, dimension (*) !> The rotation sines. Must contain at least n-1 !> elements. !> \endverbatim !> !> \ingroup givens subroutine dqrot(dir,m,n,Q,ldq,c,s) use iso_fortran_env use qrupdate_error use qrupdate_blas character, intent(in) :: dir integer, intent(in) :: m, n, ldq real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(in) :: c(*) real(real64), intent(in) :: s(*) external drot logical fwd integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. n == 1) return ! check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call qrupdate_xerror('DQROT',info) return end if if (fwd) then do i = 1,n-1 call drot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do else do i = n-1,1,-1 call drot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrqh.f90000066400000000000000000000064761522610125300233550ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Converts an upper trapezoidal matrix to upper Hessenberg form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrqh(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> double precision R(ldr,*) !> double precision c(*) !> double precision s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRQH brings an upper trapezoidal matrix R into upper Hessenberg form !> using min(m-1,n) Givens rotations. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the upper Hessenberg matrix R. On exit, !> the updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is DOUBLE PRECISION array, dimension (*) !> The rotation cosines. Must contain at least !> min(m-1,n) elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is DOUBLE PRECISION array, dimension (*) !> The rotation sines. Must contain at least !> min(m-1,n) elements. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqrqh(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr real(real64), intent(inout) :: R(ldr,*) real(real64), intent(in) :: c(*) real(real64), intent(in) :: s(*) real(real64) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('DQRQH',info) return end if do i = 1,n ii = min(m-1,i) ! apply stored rotations, column-wise t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - s(j)*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrshc.f90000066400000000000000000000124731522610125300235140ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a circular shift of columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrshc(m,n,k,Q,ldq,R,ldr,i,j,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, i, j !> .. !> .. Array Arguments .. !> double precision Q(ldq,*) !> double precision R(ldr,*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRSHC updates a QR factorization after circular shift of columns. !> i.e., given an m-by-k orthogonal matrix Q, an k-by-n upper !> trapezoidal matrix R and index j in the range 1:n+1, DQRSHC !> updates the matrix Q -> Q1 and R -> R1 so that Q1 is again !> orthogonal, R1 upper trapezoidal, and Q1*R1 = A(:,p), where A = Q*R !> and p is the permutation [1:i-1,shift(i:j,-1),j+1:n] if i < j or !> [1:j-1,shift(j:i,+1),i+1:n] if j < i. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q1, and rows of R1. Must be !> either k = m (full Q) or k = n <= m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is DOUBLE PRECISION array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is DOUBLE PRECISION array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range (see above). !> 1 <= i <= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range (see above). !> 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (*) !> A workspace vector of size 2*k. !> \endverbatim !> !> \ingroup qrdecomp subroutine dqrshc(m,n,k,Q,ldq,R,ldr,i,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, i, j real(real64), intent(inout) :: Q(ldq,*) real(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: w(*) external dqrot,dcopy,dqrtv1,dqrqh,dqhqr integer info,jj,kk,l ! quick return if possible. if (m == 0 .or. n == 1) return info = 0 ! check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call qrupdate_xerror('DQRSHC',info) return end if if (i < j) then ! shift columns call dcopy(k,R(1,i),1,w,1) do l = i,j-1 call dcopy(k,R(1,l+1),1,R(1,l),1) end do call dcopy(k,w,1,R(1,j),1) ! retriangularize if (i < k) then kk = min(k,j) call dqhqr(kk+1-i,n+1-i,R(i,i),ldr,w(k+1),w) ! apply rotations to Q. call dqrot('F',m,kk+1-i,Q(1,i),ldq,w(k+1),w) end if else if (j < i) then ! shift columns call dcopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call dcopy(k,R(1,l-1),1,R(1,l),1) end do call dcopy(k,w,1,R(1,j),1) ! retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) ! eliminate the introduced spike. call dqrtv1(kk+1-j,R(j,j),w(k+1)) ! apply rotations to R call dqrqh(kk+1-j,n-j,R(j,jj),ldr,w(k+1),R(j+1,j)) ! apply rotations to Q call dqrot('B',m,kk+1-j,Q(1,j),ldq,w(k+1),R(j+1,j)) ! zero spike. do l = j+1,kk R(l,j) = 0d0 end do end if end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/dqrtv1.f90000066400000000000000000000054131522610125300234450ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates Givens rotations to eliminate all but the first element of a vector. !> !> \par Definition: ! ============= !> \verbatim !> subroutine dqrtv1(n,u,w) !> !> .. Scalar Arguments .. !> integer n !> .. !> .. Array Arguments .. !> double precision u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> DQRTV1 generates a sequence of n-1 Givens rotations that !> eliminate all but the first element of a double precision !> vector u. On entry, u contains the vector to be reduced. !> On exit, u(1) contains the resulting element, u(2:n) contains !> the rotation sines, and w contains the rotation cosines. !> !> The rotations are generated from the bottom up, so that the !> first rotation eliminates u(n), the second eliminates u(n-1), !> and so on. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The length of the vector u. If n <= 0, the subroutine !> returns immediately without modification. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is DOUBLE PRECISION array, dimension (n) !> On entry, the vector to be reduced. On exit, u(1) !> contains the remaining element, and u(2:n) contains !> the sine parts of the Givens rotations. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations. !> \endverbatim !> !> \ingroup givens subroutine dqrtv1(n,u,w) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: u(*) real(real64), intent(out) :: w(*) external dlartg real(real64) rr,t integer i ! quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call dlartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/qrupdate.f90000066400000000000000000001021641522610125300240520ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! module qrupdate use iso_fortran_env implicit none interface subroutine caxcpy(n, a, x, incx, y, incy) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(in) :: a complex(real32), intent(in) :: x integer, intent(in) :: incx complex(real32), intent(inout) :: y integer, intent(in) :: incy end subroutine caxcpy end interface interface subroutine cch1dn(n, R, ldr, u, rw, info) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u real(real32), intent(out) :: rw integer, intent(out) :: info end subroutine cch1dn end interface interface subroutine cch1up(n, R, ldr, u, w) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u real(real32), intent(out) :: w end subroutine cch1up end interface interface subroutine cchdex(n, R, ldr, j, rw) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(out) :: rw end subroutine cchdex end interface interface subroutine cchinx(n, R, ldr, j, u, rw, info) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(inout) :: u real(real32), intent(out) :: rw integer, intent(out) :: info end subroutine cchinx end interface interface subroutine cchshx(n, R, ldr, i, j, w, rw) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j complex(real32), intent(out) :: w real(real32), intent(out) :: rw end subroutine cchshx end interface interface subroutine cgqvec(m, n, Q, ldq, u) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(in) :: Q integer, intent(in) :: ldq complex(real32), intent(out) :: u end subroutine cgqvec end interface interface subroutine clu1up(m, n, L, ldl, R, ldr, u, v) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: L integer, intent(in) :: ldl complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u complex(real32), intent(inout) :: v end subroutine clu1up end interface interface subroutine clup1up(m, n, L, ldl, R, ldr, p, u, v, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: L integer, intent(in) :: ldl complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: p complex(real32), intent(in) :: u complex(real32), intent(in) :: v complex(real32), intent(out) :: w end subroutine clup1up end interface interface subroutine cqhqr(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(out) :: c complex(real32), intent(out) :: s end subroutine cqhqr end interface interface subroutine cqr1up(m, n, k, Q, ldq, R, ldr, u, v, w, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u complex(real32), intent(inout) :: v complex(real32), intent(out) :: w real(real32), intent(out) :: rw end subroutine cqr1up end interface interface subroutine cqrdec(m, n, k, Q, ldq, R, ldr, j, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(out) :: rw end subroutine cqrdec end interface interface subroutine cqrder(m, n, Q, ldq, R, ldr, j, w, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(out) :: w real(real32), intent(out) :: rw end subroutine cqrder end interface interface subroutine cqrinc(m, n, k, Q, ldq, R, ldr, j, x, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(in) :: x real(real32), intent(out) :: rw end subroutine cqrinc end interface interface subroutine cqrinr(m, n, Q, ldq, R, ldr, j, x, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(inout) :: x real(real32), intent(out) :: rw end subroutine cqrinr end interface interface subroutine cqrot(dir, m, n, Q, ldq, c, s) use iso_fortran_env character, intent(in) :: dir integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(in) :: c complex(real32), intent(in) :: s end subroutine cqrot end interface interface subroutine cqrqh(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(in) :: c complex(real32), intent(in) :: s end subroutine cqrqh end interface interface subroutine cqrshc(m, n, k, Q, ldq, R, ldr, i, j, w, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j complex(real32), intent(out) :: w real(real32), intent(out) :: rw end subroutine cqrshc end interface interface subroutine cqrtv1(n, u, w) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: u real(real32), intent(out) :: w end subroutine cqrtv1 end interface interface subroutine dch1dn(n, R, ldr, u, w, info) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(inout) :: u real(real64), intent(out) :: w integer, intent(out) :: info end subroutine dch1dn end interface interface subroutine dch1up(n, R, ldr, u, w) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(inout) :: u real(real64), intent(out) :: w end subroutine dch1up end interface interface subroutine dchdex(n, R, ldr, j, w) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(out) :: w end subroutine dchdex end interface interface subroutine dchinx(n, R, ldr, j, u, w, info) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(inout) :: u real(real64), intent(out) :: w integer, intent(out) :: info end subroutine dchinx end interface interface subroutine dchshx(n, R, ldr, i, j, w) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j real(real64), intent(out) :: w end subroutine dchshx end interface interface subroutine dgqvec(m, n, Q, ldq, u) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(in) :: Q integer, intent(in) :: ldq real(real64), intent(out) :: u end subroutine dgqvec end interface interface subroutine dlu1up(m, n, L, ldl, R, ldr, u, v) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: L integer, intent(in) :: ldl real(real64), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(inout) :: u real(real64), intent(inout) :: v end subroutine dlu1up end interface interface subroutine dlup1up(m, n, L, ldl, R, ldr, p, u, v, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: L integer, intent(in) :: ldl real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: p real(real64), intent(in) :: u real(real64), intent(in) :: v real(real64), intent(out) :: w end subroutine dlup1up end interface interface subroutine dqhqr(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(out) :: c real(real64), intent(out) :: s end subroutine dqhqr end interface interface subroutine dqr1up(m, n, k, Q, ldq, R, ldr, u, v, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(inout) :: u real(real64), intent(inout) :: v real(real64), intent(out) :: w end subroutine dqr1up end interface interface subroutine dqrdec(m, n, k, Q, ldq, R, ldr, j, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(out) :: w end subroutine dqrdec end interface interface subroutine dqrder(m, n, Q, ldq, R, ldr, j, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(out) :: w end subroutine dqrder end interface interface subroutine dqrinc(m, n, k, Q, ldq, R, ldr, j, x, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(in) :: x real(real64), intent(out) :: w end subroutine dqrinc end interface interface subroutine dqrinr(m, n, Q, ldq, R, ldr, j, x, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(inout) :: x real(real64), intent(out) :: w end subroutine dqrinr end interface interface subroutine dqrot(dir, m, n, Q, ldq, c, s) use iso_fortran_env character, intent(in) :: dir integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(in) :: c real(real64), intent(in) :: s end subroutine dqrot end interface interface subroutine dqrqh(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real64), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(in) :: c real(real64), intent(in) :: s end subroutine dqrqh end interface interface subroutine dqrshc(m, n, k, Q, ldq, R, ldr, i, j, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real64), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j real(real64), intent(out) :: w end subroutine dqrshc end interface interface subroutine dqrtv1(n, u, w) use iso_fortran_env integer, intent(in) :: n real(real64), intent(inout) :: u real(real64), intent(out) :: w end subroutine dqrtv1 end interface interface subroutine sch1dn(n, R, ldr, u, w, info) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(inout) :: u real(real32), intent(out) :: w integer, intent(out) :: info end subroutine sch1dn end interface interface subroutine sch1up(n, R, ldr, u, w) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(inout) :: u real(real32), intent(out) :: w end subroutine sch1up end interface interface subroutine schdex(n, R, ldr, j, w) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(out) :: w end subroutine schdex end interface interface subroutine schinx(n, R, ldr, j, u, w, info) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(inout) :: u real(real32), intent(out) :: w integer, intent(out) :: info end subroutine schinx end interface interface subroutine schshx(n, R, ldr, i, j, w) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j real(real32), intent(out) :: w end subroutine schshx end interface interface subroutine sgqvec(m, n, Q, ldq, u) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(in) :: Q integer, intent(in) :: ldq real(real32), intent(out) :: u end subroutine sgqvec end interface interface subroutine slu1up(m, n, L, ldl, R, ldr, u, v) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: L integer, intent(in) :: ldl real(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(inout) :: u real(real32), intent(inout) :: v end subroutine slu1up end interface interface subroutine slup1up(m, n, L, ldl, R, ldr, p, u, v, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: L integer, intent(in) :: ldl real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: p real(real32), intent(in) :: u real(real32), intent(in) :: v real(real32), intent(out) :: w end subroutine slup1up end interface interface subroutine sqhqr(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(out) :: c real(real32), intent(out) :: s end subroutine sqhqr end interface interface subroutine sqr1up(m, n, k, Q, ldq, R, ldr, u, v, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(inout) :: u real(real32), intent(inout) :: v real(real32), intent(out) :: w end subroutine sqr1up end interface interface subroutine sqrdec(m, n, k, Q, ldq, R, ldr, j, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(out) :: w end subroutine sqrdec end interface interface subroutine sqrder(m, n, Q, ldq, R, ldr, j, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(out) :: w end subroutine sqrder end interface interface subroutine sqrinc(m, n, k, Q, ldq, R, ldr, j, x, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(in) :: x real(real32), intent(out) :: w end subroutine sqrinc end interface interface subroutine sqrinr(m, n, Q, ldq, R, ldr, j, x, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real32), intent(inout) :: x real(real32), intent(out) :: w end subroutine sqrinr end interface interface subroutine sqrot(dir, m, n, Q, ldq, c, s) use iso_fortran_env character, intent(in) :: dir integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(in) :: c real(real32), intent(in) :: s end subroutine sqrot end interface interface subroutine sqrqh(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n real(real32), intent(inout) :: R integer, intent(in) :: ldr real(real32), intent(in) :: c real(real32), intent(in) :: s end subroutine sqrqh end interface interface subroutine sqrshc(m, n, k, Q, ldq, R, ldr, i, j, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k real(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j real(real32), intent(out) :: w end subroutine sqrshc end interface interface subroutine sqrtv1(n, u, w) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: u real(real32), intent(out) :: w end subroutine sqrtv1 end interface interface subroutine zaxcpy(n, a, x, incx, y, incy) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(in) :: a complex(real32), intent(in) :: x integer, intent(in) :: incx complex(real32), intent(inout) :: y integer, intent(in) :: incy end subroutine zaxcpy end interface interface subroutine zch1dn(n, R, ldr, u, rw, info) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u real(real64), intent(out) :: rw integer, intent(out) :: info end subroutine zch1dn end interface interface subroutine zch1up(n, R, ldr, u, w) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u real(real64), intent(out) :: w end subroutine zch1up end interface interface subroutine zchdex(n, R, ldr, j, rw) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(out) :: rw end subroutine zchdex end interface interface subroutine zchinx(n, R, ldr, j, u, rw, info) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(inout) :: u real(real64), intent(out) :: rw integer, intent(out) :: info end subroutine zchinx end interface interface subroutine zchshx(n, R, ldr, i, j, w, rw) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j complex(real32), intent(out) :: w real(real64), intent(out) :: rw end subroutine zchshx end interface interface subroutine zgqvec(m, n, Q, ldq, u) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(in) :: Q integer, intent(in) :: ldq complex(real32), intent(out) :: u end subroutine zgqvec end interface interface subroutine zlu1up(m, n, L, ldl, R, ldr, u, v) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: L integer, intent(in) :: ldl complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u complex(real32), intent(inout) :: v end subroutine zlu1up end interface interface subroutine zlup1up(m, n, L, ldl, R, ldr, p, u, v, w) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: L integer, intent(in) :: ldl complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: p complex(real32), intent(in) :: u complex(real32), intent(in) :: v complex(real32), intent(out) :: w end subroutine zlup1up end interface interface subroutine zqhqr(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(out) :: c complex(real32), intent(out) :: s end subroutine zqhqr end interface interface subroutine zqr1up(m, n, k, Q, ldq, R, ldr, u, v, w, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr complex(real32), intent(inout) :: u complex(real32), intent(inout) :: v complex(real32), intent(out) :: w real(real64), intent(out) :: rw end subroutine zqr1up end interface interface subroutine zqrdec(m, n, k, Q, ldq, R, ldr, j, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j real(real64), intent(out) :: rw end subroutine zqrdec end interface interface subroutine zqrder(m, n, Q, ldq, R, ldr, j, w, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(out) :: w real(real64), intent(out) :: rw end subroutine zqrder end interface interface subroutine zqrinc(m, n, k, Q, ldq, R, ldr, j, x, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(in) :: x real(real64), intent(out) :: rw end subroutine zqrinc end interface interface subroutine zqrinr(m, n, Q, ldq, R, ldr, j, x, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: j complex(real32), intent(inout) :: x real(real64), intent(out) :: rw end subroutine zqrinr end interface interface subroutine zqrot(dir, m, n, Q, ldq, c, s) use iso_fortran_env character, intent(in) :: dir integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: Q integer, intent(in) :: ldq real(real64), intent(in) :: c complex(real32), intent(in) :: s end subroutine zqrot end interface interface subroutine zqrqh(m, n, R, ldr, c, s) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n complex(real32), intent(inout) :: R integer, intent(in) :: ldr real(real64), intent(in) :: c complex(real32), intent(in) :: s end subroutine zqrqh end interface interface subroutine zqrshc(m, n, k, Q, ldq, R, ldr, i, j, w, rw) use iso_fortran_env integer, intent(in) :: m integer, intent(in) :: n integer, intent(in) :: k complex(real32), intent(inout) :: Q integer, intent(in) :: ldq complex(real32), intent(inout) :: R integer, intent(in) :: ldr integer, intent(in) :: i integer, intent(in) :: j complex(real32), intent(out) :: w real(real64), intent(out) :: rw end subroutine zqrshc end interface interface subroutine zqrtv1(n, u, w) use iso_fortran_env integer, intent(in) :: n complex(real32), intent(inout) :: u real(real64), intent(out) :: w end subroutine zqrtv1 end interface end module qrupdate qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/qrupdate_blas.f90000066400000000000000000000071701522610125300250540ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! ! ! This module contains the (c/z)dot(u/c) replacements to obtain a ! Fortran (gfortran/flang) ABI invariant implementation. ! Furthermore, I provides the interface to LAPACK's xerbla. ! module qrupdate_blas use iso_fortran_env implicit none interface subroutine qrupdate_cdotc(ret,n,cx,incx,cy,incy) use iso_fortran_env integer, intent(in) :: incx, incy, n complex(real32), intent(in) :: cx(*),cy(*) complex(real32), intent(out) :: ret end subroutine qrupdate_cdotc end interface interface subroutine qrupdate_cdotu(ret,n,cx,incx,cy,incy) use iso_fortran_env integer, intent(in) :: incx, incy, n complex(real32), intent(in) :: cx(*),cy(*) complex(real32), intent(out) :: ret end subroutine qrupdate_cdotu end interface interface subroutine qrupdate_zdotc(ret,n,cx,incx,cy,incy) use iso_fortran_env integer, intent(in) :: incx, incy, n complex(real64), intent(in) :: cx(*),cy(*) complex(real64), intent(out) :: ret end subroutine qrupdate_zdotc end interface interface subroutine qrupdate_zdotu(ret,n,cx,incx,cy,incy) use iso_fortran_env integer, intent(in) :: incx, incy, n complex(real64), intent(in) :: cx(*),cy(*) complex(real64), intent(out) :: ret end subroutine qrupdate_zdotu end interface interface subroutine xerbla( srname, info ) character*(*), intent(in) :: srname integer, intent(in) :: info end subroutine end interface contains function lsame( ca, cb ) character, intent(in) :: ca, cb logical :: lsame integer :: inta, intb, zcode lsame = ca == cb if ( lsame ) return zcode = ichar( 'Z' ) inta = ichar( ca ) intb = ichar( cb ) if ( zcode == 90 .or. zcode == 122 ) then ! ASCII if ( inta >= 97 .and. inta <= 122 ) inta = inta - 32 if ( intb >= 97 .and. intb <= 122 ) intb = intb - 32 else if ( zcode == 233 .or. zcode == 169 ) then ! EBCDIC if ( ( inta >= 129 .and. inta <= 137 ) .or. & ( inta >= 145 .and. inta <= 153 ) .or. & ( inta >= 162 .and. inta <= 169 ) ) inta = inta + 64 if ( ( intb >= 129 .and. intb <= 137 ) .or. & ( intb >= 145 .and. intb <= 153 ) .or. & ( intb >= 162 .and. intb <= 169 ) ) intb = intb + 64 else if ( zcode == 218 .or. zcode == 250 ) then ! ASCII on Prime machines if ( inta >= 225 .and. inta <= 250 ) inta = inta - 32 if ( intb >= 225 .and. intb <= 250 ) intb = intb - 32 end if lsame = inta == intb end function lsame end module qrupdate_blas qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/qrupdate_error.f90000066400000000000000000000065021522610125300252620ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Module for custom error handling. !> !> This module provides a mechanism to override the default BLAS/LAPACK !> error handler (xerbla). Users can specify a custom subroutine to !> handle errors, along with optional auxiliary data. module qrupdate_error use qrupdate_blas implicit none !> \brief Abstract interface for custom error handlers. !> \ingroup error abstract interface subroutine error_handler_if(srname, info, aux) character(len=*), intent(in) :: srname integer, intent(in) :: info class(*), optional, intent(in) :: aux end subroutine error_handler_if end interface procedure(error_handler_if), pointer :: global_error_handler => null() class(*), pointer :: global_error_aux => null() private :: global_error_handler, global_error_aux contains !> \brief Sets the custom error handler. !> !> \param[in] p_handler !> \verbatim !> p_handler is a procedure pointer conforming to the !> error_handler_if interface. !> \endverbatim !> \ingroup error subroutine qrupdate_set_error(p_handler) procedure(error_handler_if), pointer, intent(in) :: p_handler global_error_handler => p_handler end subroutine qrupdate_set_error !> \brief Sets auxiliary data for the error handler. !> !> \param[in] p_aux !> \verbatim !> p_aux is a pointer to a polymorphic object (class(*)) !> that will be passed to the error handler. !> \endverbatim !> \ingroup error subroutine qrupdate_set_error_data(p_aux) class(*), pointer :: p_aux global_error_aux => p_aux end subroutine qrupdate_set_error_data !> \brief Dispatches error reporting to the handler. !> !> This subroutine checks if a custom error handler has been set via !> qrupdate_set_error. If so, it calls that handler with the provided !> routine name, error code, and any set auxiliary data. Otherwise, it !> falls back to the standard LAPACK xerbla routine. !> !> \param[in] srname !> \verbatim !> srname is CHARACTER(LEN=*) !> The name of the routine that encountered the error. !> \endverbatim !> \param[in] info !> \verbatim !> info is INTEGER !> The error code. !> \endverbatim !> \ingroup error subroutine qrupdate_xerror(srname, info) character(len=*), intent(in) :: srname integer, intent(in) :: info if (associated(global_error_handler)) then call global_error_handler(srname, info, global_error_aux) else call xerbla(srname, info) end if end subroutine qrupdate_xerror end module qrupdate_error qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sch1dn.f90000066400000000000000000000105671522610125300234120ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Downdates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sch1dn(n,R,ldr,u,w,info) !> !> .. Scalar Arguments .. !> integer n, ldr, info !> .. !> .. Array Arguments .. !> real R(ldr,*), u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SCH1DN downdates the Cholesky factorization of a symmetric !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R.'*R, where R.' denotes the transpose of R, SCH1DN !> downdates R -> R1 so that R1.'*R1 = A - u*u.', where u is a !> given vector. !> !> The downdate is performed by applying a sequence of hyperbolic !> rotations to restore the upper triangular structure of R. On !> exit, u contains the rotation sines and w contains the rotation !> cosines used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A - u*u.'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is REAL array, dimension (n) !> On entry, the vector determining the rank-1 downdate. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n) !> On exit, w contains the cosine parts of the !> rotations used to transform R to R1. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> \endverbatim !> !> \ingroup choldecomp subroutine sch1dn(n,R,ldr,u,w,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr real(real32), intent(inout) :: R(ldr,*), u(*) real(real32), intent(out) :: w(*) integer, intent(out) :: info external strsv,slartg,snrm2 real(real32) snrm2,rho,rr,ui,t integer i,j ! quick return if possible. if (n == 0) return ! check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call qrupdate_xerror('SCH1DN',-info) return end if ! check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do ! form R' \ u call strsv('U','T','N',n,R,ldr,u,1) rho = snrm2(n,u,1) ! check positive definiteness rho = 1 - rho**2 if (rho <= 0e0) goto 10 rho = sqrt(rho) ! eliminate R' \ u do i = n,1,-1 ui = u(i) ! generate next rotation call slartg(rho,ui,w(i),u(i),rr) rho = rr end do ! apply rotations do i = n,1,-1 ui = 0e0 do j = i,1,-1 t = w(j)*ui + u(j)*R(j,i) R(j,i) = w(j)*R(j,i) - u(j)*ui ui = t end do end do ! normal return return ! error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sch1up.f90000066400000000000000000000065741522610125300234400ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sch1up(n,R,ldr,u,w) !> !> .. Scalar Arguments .. !> integer n, ldr !> .. !> .. Array Arguments .. !> real R(ldr,*), u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SCH1UP updates the Cholesky factorization of a symmetric !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R.'*R, where R.' denotes the transpose of R, SCH1UP !> updates R -> R1 so that R1.'*R1 = A + u*u.', where u is a given !> vector. !> !> The update is performed by applying a sequence of Givens rotations !> to restore the upper triangular structure of R. On exit, u !> contains the rotation sines and w contains the rotation cosines !> used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A + u*u.'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is REAL array, dimension (n) !> On entry, the vector determining the rank-1 update. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations used to transform R to R1. !> \endverbatim !> !> \ingroup choldecomp subroutine sch1up(n,R,ldr,u,w) use iso_fortran_env integer, intent(in) :: n, ldr real(real32), intent(inout) :: R(ldr,*), u(*) real(real32), intent(out) :: w(*) external slartg real(real32) rr,ui,t integer i,j do i = 1,n ! apply stored rotations, column-wise ui = u(i) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - u(j)*R(j,i) R(j,i) = t end do ! generate next rotation call slartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/schdex.f90000066400000000000000000000061561522610125300235070ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after deleting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine schdex(n,R,ldr,j,w) !> !> .. Scalar Arguments .. !> integer n, ldr, j !> .. !> .. Array Arguments .. !> real R(ldr,*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SCHDEX updates the Cholesky factorization of a symmetric !> positive definite matrix A after deleting a row/column. !> Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R.'*R, where R.' denotes the !> transpose of R, SCHDEX updates R -> R1 so that !> R1.'*R1 = A(jj,jj), where jj = [1:j-1, j+1:n+1]. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(jj,jj). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row/column. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n) !> A workspace vector. !> \endverbatim !> !> \ingroup choldecomp subroutine schdex(n,R,ldr,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, j real(real32), intent(inout) :: R(ldr,*) real(real32), intent(out) :: w(*) integer info,i external scopy,sqhqr ! quick return if possible. if (n == 1) return ! check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call qrupdate_xerror('SCHDEX',info) return end if ! delete the j-th column. do i = j,n-1 call scopy(n,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < n) then call sqhqr(n+1-j,n-j,R(j,j),ldr,w,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/schinx.f90000066400000000000000000000111571522610125300235220ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after inserting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine schinx(n,R,ldr,j,u,w,info) !> !> .. Scalar Arguments .. !> integer n, j, ldr, info !> .. !> .. Array Arguments .. !> real R(ldr,*), u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SCHINX updates the Cholesky factorization of a symmetric !> positive definite matrix A after inserting a row and column. !> Given an upper triangular matrix R that is a Cholesky factor of !> A, i.e., A = R.'*R, where R.' denotes the transpose of R, this !> SCHINX updates R -> R1 so that R1.'*R1 = A1, where !> A1(jj,jj) = A, A1(j,:) = u.', A1(:,j) = u, and !> jj = [1:j-1, j+1:n+1]. !> !> On exit, u is destroyed and R is extended by one row and column. !> The insertion is performed by first solving R.'*u = v, checking !> positive definiteness, and then retriangularizing. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n+1) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the inserted row and column. !> 1 <= j <= n+1. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is REAL array, dimension (n+1) !> On entry, the vector defining the inserted row/column. !> On exit, u is destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n+1) !> Workspace vector used during the retriangularization. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> \endverbatim !> !> \ingroup choldecomp subroutine schinx(n,R,ldr,j,u,w,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, j, ldr real(real32), intent(inout) :: R(ldr,*) real(real32), intent(inout) :: u(*) real(real32), intent(out) :: w(*) integer, intent(out) :: info external scopy,snrm2,strsv,sqrtv1,sqrqh real(real32) snrm2,rho,t integer i ! check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call qrupdate_xerror('SCHINX',info) return end if ! shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do ! check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do ! form R' \ u call strsv('U','T','N',n,R,ldr,u,1) rho = snrm2(n,u,1) ! check positive definiteness. rho = t - rho**2 if (rho <= 0e0) goto 10 ! shift columns do i = n,j,-1 call scopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0e0 end do call scopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) ! retriangularize if (j < n+1) then ! eliminate the introduced spike. call sqrtv1(n+2-j,R(j,j),w) ! apply rotations to R call sqrqh(n+2-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) ! zero spike. do i = j+1,n+1 R(i,j) = 0e0 end do end if ! normal return. return ! error returns. 10 info = 1 return 20 info = 2 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/schshx.f90000066400000000000000000000101001522610125300235110ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a symmetric shift of rows and columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine schshx(n,R,ldr,i,j,w) !> !> .. Scalar Arguments .. !> integer n, ldr, i, j !> .. !> .. Array Arguments .. !> real R(ldr,*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SCHSHX updates the Cholesky factorization of a symmetric !> positive definite matrix A after a symmetric shift of rows and !> columns. Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R.'*R, where R.' denotes the transpose !> of R, SCHSHX updates R -> R1 so that !> R1.'*R1 = A(p,p), where p is the permutation !> [1:i-1, shift(i:j,-1), j+1:n] if i < j, or !> [1:j-1, shift(j:i,+1), i+1:n] if j < i. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(p,p). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range of the shift. !> 1 <= i <= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range of the shift. !> 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (2*n) !> Workspace vector used during the retriangularization. !> \endverbatim !> !> \ingroup choldecomp subroutine schshx(n,R,ldr,i,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, i, j real(real32), intent(inout) :: R(ldr,*) real(real32), intent(out) :: w(*) external scopy,sqrtv1,sqrqh,sqhqr integer info,l ! quick return if possible. if (n == 0 .or. n == 1) return info = 0 ! check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call qrupdate_xerror('SCHSHX',info) return end if if (i < j) then ! shift columns call scopy(n,R(1,i),1,w,1) do l = i,j-1 call scopy(n,R(1,l+1),1,R(1,l),1) end do call scopy(n,w,1,R(1,j),1) ! retriangularize call sqhqr(n+1-i,n+1-i,R(i,i),ldr,w(n+1),w) else if (j < i) then ! shift columns call scopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call scopy(n,R(1,l-1),1,R(1,l),1) end do call scopy(n,w,1,R(1,j),1) ! eliminate the introduced spike. call sqrtv1(n+1-j,R(j,j),w(n+1)) ! apply rotations to R call sqrqh(n+1-j,n-j,R(j,j+1),ldr,w(n+1),R(j+1,j)) ! zero spike. do l = j+1,n R(l,j) = 0e0 end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sgqvec.f90000066400000000000000000000074431522610125300235210ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates a unit vector orthogonal to the column space of a unitary matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sgqvec(m,n,Q,ldq,u) !> !> .. Scalar Arguments .. !> integer m, n, ldq !> .. !> .. Array Arguments .. !> real Q(ldq,*), u(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SGQVEC generates a vector u in the orthogonal complement of the !> column space of an orthogonal matrix Q. Given an m-by-n !> orthogonal matrix Q with n < m, SGQVEC generates a !> vector u of length m such that Q.'*u = 0 and norm(u) = 1, where !> Q.' denotes the transpose of Q. !> !> The algorithm projects canonical unit vectors onto the orthogonal !> complement of Q's column space until a nonzero result is found. !> If n = 0, the first canonical unit vector is returned. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0 and !> n < m. !> \endverbatim !> !> \param[in] Q !> \verbatim !> Q is REAL array, dimension (ldq,n) !> The orthogonal m-by-n matrix Q. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of the array Q. ldq >= m. !> \endverbatim !> !> \param[out] u !> \verbatim !> u is REAL array, dimension (m) !> The generated vector such that Q.'*u = 0 and norm(u) = 1. !> \endverbatim !> !> \ingroup qrdecomp subroutine sgqvec(m,n,Q,ldq,u) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldq real(real32), intent(in) :: Q(ldq,*) real(real32), intent(out) :: u(*) external sdot,saxpy,snrm2,sscal real(real32) sdot,snrm2,r integer info,i,j ! quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1e0 do i = 2,m u(i) = 0e0 end do return end if ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('SGQVEC',info) return end if j = 1 r = 0e0 do while ( r .eq. 0e0 ) ! probe j-th canonical unit vector. do i = 1,m u(i) = 0e0 end do u(j) = 1e0 ! form u - Q*Q'*u do i = 1,n r = sdot(m,Q(1,i),1,u,1) call saxpy(m,-r,Q(1,i),1,u,1) end do r = snrm2(m,u,1) if (r == 0e0) then j = j + 1 if (j > n) then ! this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in SGQVEC' end if end if end do call sscal(m,1e0/r,u,1) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/slu1up.f90000066400000000000000000000113261522610125300234550ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates an LU factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine slu1up(m,n,L,ldl,R,ldr,u,v) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> real L(ldl,*), R(ldr,*), u(*), v(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SLU1UP updates an LU factorization after rank-1 modification. !> Given an m-by-k lower-triangular matrix L with unit diagonal and !> a k-by-n upper-trapezoidal matrix R, where k = min(m,n), this !> SLU1UP updates L -> L1 and R -> R1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, and !> L1*R1 = L*R + u*v.', where v.' denotes the transpose of v. !> !> The update is performed using the Bennett algorithm with !> column-major access, which processes the leading k-by-k block !> first and then finishes the trailing part of R if needed. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is REAL array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is REAL array, dimension (m) !> On entry, the left m-vector defining the rank-1 !> modification. On exit, if k < m, u is destroyed; !> otherwise, u contains the updated vector. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is REAL array, dimension (n) !> On entry, the right n-vector defining the rank-1 !> modification. On exit, v is destroyed. !> \endverbatim !> !> \ingroup ludecomp subroutine slu1up(m,n,L,ldl,R,ldr,u,v) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr real(real32), intent(inout) :: L(ldl,*), R(ldr,*) real(real32), intent(inout) :: u(*), v(*) real(real32) ui,vi integer k,info,i,j ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('SLU1UP',info) return end if ! The Bennett algorithm, modified for column-major access. ! The leading part. do i = 1,k ! prefetch ui = u(i) vi = v(i) ! delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do ! diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) ! L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do ! Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/slup1up.f90000066400000000000000000000154501522610125300236370ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a row-pivoted LU factorization after rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine slup1up(m,n,L,ldl,R,ldr,p,u,v,w) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> integer p(*) !> real L(ldl,*), R(ldr,*), u(*), v(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SLUP1UP updates a row-pivoted LU factorization after rank-1 !> modification. Given an m-by-k lower-triangular matrix L with !> unit diagonal, a k-by-n upper-trapezoidal matrix R, and a !> permutation vector p, where k = min(m,n), SLUP1UP !> updates L -> L1, R -> R1 and p -> p1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, p1 a permutation, !> and P1.'*L1*R1 = P.'*L*R + u*v.', where v.' denotes the !> transpose of v and P is the permutation matrix corresponding !> to p. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is REAL array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in] p !> \verbatim !> p is INTEGER array, dimension (m) !> The permutation vector representing the row pivoting. !> On exit, p is updated to reflect the new pivoting. !> \endverbatim !> !> \param[in] u !> \verbatim !> u is REAL array, dimension (m) !> The left m-vector defining the rank-1 modification. !> \endverbatim !> !> \param[in] v !> \verbatim !> v is REAL array, dimension (n) !> The right n-vector defining the rank-1 modification. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (m) !> Workspace vector used during the update computation. !> \endverbatim !> !> \ingroup ludecomp subroutine slup1up(m,n,L,ldl,R,ldr,p,u,v,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr integer, intent(inout) :: p(*) real(real32), intent(inout) :: L(ldl,*), R(ldr,*) real(real32), intent(in) :: u(*), v(*) real(real32), intent(out) :: w(*) real(real32) one,tau,tmp parameter (one = 1e0, tau = 1e-1) integer k,info,i,j,itmp external scopy,saxpy,strsv,sger,sgemv,sswap ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('SLUP1UP',info) return end if ! form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call strsv('L','N','U',k,L,ldl,w,1) ! if m > k = n, subtract the trailing part. if (m > k) then call sgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if ! work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then ! need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call sswap(m-j+1,L(j,j),1,L(j,j+1),1) call sswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call sswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call saxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call saxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) ! update w w(j) = w(j) - tmp*w(j+1) end if ! eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 ! update R. call saxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) ! update L. call saxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! add a multiple of v to R call saxpy(n,w(1),v,1,R(1,1),ldr) ! forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then ! need pivoting. swap j and j+1 ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call sswap(m-j+1,L(j,j),1,L(j,j+1),1) call sswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call sswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call saxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call saxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if ! eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) ! update R. R(j+1,j) = 0e0 call saxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) ! update L. call saxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! if m > k = n, complete the update by updating the lower part of L. if (m > k) then call scopy(k,v,1,w,1) call strsv('U','T','N',k,R,ldr,w,1) call sger(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqhqr.f90000066400000000000000000000074021522610125300233620ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Reduces an upper Hessenberg matrix to upper trapezoidal form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqhqr(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> real R(ldr,*), c(*), s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQHQR reduces an m-by-n upper Hessenberg matrix R to upper !> trapezoidal form. Given an m-by-n upper Hessenberg matrix R, !> SQHQR applies min(m-1,n) Givens rotations from the !> left to eliminate the subdiagonal elements, producing an upper !> trapezoidal matrix. !> !> On exit, c contains the cosine parts and s contains the sine !> parts of the Givens rotations used in the reduction. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,n) !> On entry, the upper Hessenberg matrix R. On exit, the !> updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= m. !> \endverbatim !> !> \param[out] c !> \verbatim !> c is REAL array, dimension (min(m-1,n)) !> On exit, the cosine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \param[out] s !> \verbatim !> s is REAL array, dimension (min(m-1,n)) !> On exit, the sine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqhqr(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr real(real32), intent(inout) :: R(ldr,*) real(real32), intent(in) :: c(*) real(real32), intent(in) :: s(*) external slartg real(real32) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('SQHQR',info) return end if do i = 1,n ! apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - s(j)*t end do if (ii < m) then ! generate next rotation call slartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0e0 else R(ii,i) = t end if end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqr1up.f90000066400000000000000000000123731522610125300234620ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqr1up(m,n,k,Q,ldq,R,ldr,u,v,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real R(ldr,*) !> real u(*) !> real v(*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQR1UP updates a QR factorization after rank-1 modification i.e., !> given a m-by-k orthogonal Q and m-by-n upper trapezoidal R, an !> m-vector u and n-vector v, SQR1UP updates Q -> Q1 and R -> !> R1 so that Q1*R1 = Q*R + u*v', and Q1 is again orthonormal and R1 !> upper trapezoidal. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n < m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the upper trapezoidal m-by-n matrix R. On !> exit, the updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is REAL array, dimension (*) !> On entry, the left m-vector. On exit, if k < m, !> u is destroyed. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is REAL array, dimension (*) !> On entry, the right n-vector. On exit, v is !> destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (*) !> A workspace vector of size 2*k. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqr1up(m,n,k,Q,ldq,R,ldr,u,v,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr real(real32), intent(inout) :: Q(ldq,*), R(ldr,*) real(real32), intent(inout) :: u(*), v(*) real(real32), intent(out) :: w(*) external sqrqh,sqhqr,sqrot,sqrtv1,sch1up external saxpy,sdot,snrm2,slamch,sscal,srot real(real32) sdot,snrm2,slamch,ru,ruu integer info,i logical full ! quick return if possible. if (k == 0 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call qrupdate_xerror('SQR1UP',info) return end if full = k == m ! in the non-full case, we shall need the norm of u. ru = 1.0 if (.not.full) ru = snrm2(m,u,1) ! form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k w(i) = sdot(m,Q(1,i),1,u,1) if (.not.full) call saxpy(m,-w(i),Q(1,i),1,u,1) end do ! generate rotations to eliminate Q'*u. call sqrtv1(k,w,w(k+1)) ! apply rotations to R. call sqrqh(k,n,R,ldr,w(k+1),w(2)) ! apply rotations to Q. call sqrot('B',m,k,Q,ldq,w(k+1),w(2)) ! update the first row of R. call saxpy(n,w(1),v,1,R(1,1),ldr) ! retriangularize R. call sqhqr(k,n,R,ldr,w(k+1),w) ! apply rotations to Q. call sqrot('F',m,min(k,n+1),Q,ldq,w(k+1),w) ! in the full case, we're finished if (full) return ! compute relative residual norm ruu = snrm2(m,u,1) ru = ru * slamch('e') if (ruu <= ru) return ! update the orthogonal basis. call sscal(n,ruu,v,1) call sscal(m,1e0/ruu,u,1) call sch1up(n,R,ldr,v,w(k+1)) do i = 1,n call srot(m,Q(1,i),1,u,1,w(k+i),v(i)) end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrdec.f90000066400000000000000000000102621522610125300235030ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrdec(m,n,k,Q,ldq,R,ldr,j,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real R(ldr,*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRDEC updates a QR factorization after deleting a column. i.e., !> given an m-by-k orthogonal matrix Q, an k-by-n upper trapezoidal !> matrix R and index j in the range 1:n+1, SQRDEC updates the !> matrix Q -> Q1 and R -> R1 so that Q1 remains orthogonal, R1 is upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], where A = Q*R. !> (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n < m (economical form, !> basis dimension will decrease). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted column in R. 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (*) !> A workspace vector of size k-j. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqrdec(m,n,k,Q,ldq,R,ldr,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j real(real32), intent(inout) :: Q(ldq,*), R(ldr,*) real(real32), intent(out) :: w(*) external scopy,sqhqr,sqrot integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('SQRDEC',info) return end if ! delete the j-th column. do i = j,n-1 call scopy(k,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < k) then call sqhqr(k+1-j,n-j,R(j,j),ldr,w,R(1,n)) ! apply rotations to Q. call sqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,w,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrder.f90000066400000000000000000000075621522610125300235330ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrder(m,n,Q,ldq,R,ldr,j,w) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real R(ldr,*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRDER updates a QR factorization after deleting a row. i.e., given !> an m-by-m orthogonal matrix Q, an m-by-n upper trapezoidal matrix R !> and index j in the range 1:m, SQRDER updates Q ->Q1 and an R !> -> R1 so that Q1 is again orthogonal, R1 upper trapezoidal, and Q1*R1 !> = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 1. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the orthogonal matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row. 1 <= j <= m. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (*) !> A workspace vector of size 2*m. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqrder(m,n,Q,ldq,R,ldr,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr real(real32), intent(inout) :: Q(ldq,*), R(ldr,*) real(real32), intent(out) :: w(*) external scopy,sqrtv1,sqrot,sqrqh integer info,i,k ! quick return if possible. if (m == 1) return ! check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call qrupdate_xerror('SQRDER',info) return end if ! eliminate Q(j,2:m). call scopy(m,Q(j,1),ldq,w,1) call sqrtv1(m,w,w(m+1)) ! apply rotations to Q. call sqrot('B',m,m,Q,ldq,w(m+1),w(2)) ! form Q1. do k = 1,m-1 if (j > 1) call scopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call scopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do ! apply rotations to R. call sqrqh(m,n,R,ldr,w(m+1),w(2)) ! form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrinc.f90000066400000000000000000000131641522610125300235250ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrinc(m,n,k,Q,ldq,R,ldr,j,x,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real R(ldr,*) !> real x(*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRINC updates a QR factorization after inserting a new column. i.e., !> given an m-by-k orthogonal matrix Q, an m-by-n upper trapezoidal !> matrix R and index j in the range 1:n+1, SQRINC updates the !> matrix Q -> Q1 and R -> R1 so that Q1 is again orthogonal, R1 upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], where A = Q*R. !> (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n <= m (economical form, !> basis dimension will increase). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= min(m,n+1). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new column in R1. 1 <= j <= n+1. !> \endverbatim !> !> \param[in] x !> \verbatim !> x is REAL array, dimension (*) !> The column being inserted. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (*) !> A workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqrinc(m,n,k,Q,ldq,R,ldr,j,x,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j real(real32), intent(inout) :: Q(ldq,*), R(ldr,*) real(real32), intent(in) :: x(*) real(real32), intent(out) :: w(*) external sqrtv1,sqrqh,sqrot external scopy,sdot,saxpy,sscal,snrm2,sgqvec real(real32) sdot,snrm2,rx integer info,i,k1 logical full ! quick return if possible. if (m == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('SQRINC',info) return end if full = k == m ! insert empty column at j-th position. do i = n,j,-1 call scopy(k,R(1,i),1,R(1,i+1),1) end do ! insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k R(i,j) = sdot(m,Q(1,i),1,x,1) end do else k1 = k + 1 ! zero last row of R do i = 1,n+1 R(k1,i) = 0e0 end do call scopy(m,x,1,Q(1,k1),1) do i = 1,k R(i,j) = sdot(m,Q(1,i),1,Q(1,k1),1) call saxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do ! get norm of the inserted column rx = snrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0e0) then ! in the rare case when rx is exact zero, we still need to provide ! a valid orthogonal unit vector. The details are boring, so handle ! that elsewhere. call sgqvec(m,k,Q,ldq,Q(1,k1)) else ! otherwise, just normalize the added column. call sscal(m,1e0/rx,Q(1,k1),1) end if end if ! maybe we're finished. if (j > k) return ! eliminate the spike. call sqrtv1(k1+1-j,R(j,j),w) ! apply rotations to R(j:k,j:n). if (j <= n) call sqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) ! apply rotations to Q(:,j:k). call sqrot('B',m,k1+1-j,Q(1,j),ldq,w,R(j+1,j)) ! zero spike. do i = j+1,k1 R(i,j) = 0e0 end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrinr.f90000066400000000000000000000105631522610125300235440ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrinr(m,n,Q,ldq,R,ldr,j,x,w) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real R(ldr,*) !> real x(*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRINR updates a QR factorization after inserting a new row. i.e., !> given an m-by-m orthogonal matrix Q, an m-by-n upper trapezoidal !> matrix R and index j in the range 1:m+1, SQRINR updates Q -> !> Q1 and R -> R1 so that Q1 is again orthogonal, R1 upper trapezoidal, !> and Q1*R1 = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the orthogonal matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m+1. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new row in R1. 1 <= j <= m+1. !> \endverbatim !> !> \param[in,out] x !> \verbatim !> x is REAL array, dimension (*) !> On entry, the row being added. On exit, x is !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (*) !> A workspace vector of size min(m,n). !> \endverbatim !> !> \ingroup qrdecomp subroutine sqrinr(m,n,Q,ldq,R,ldr,j,x,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr real(real32), intent(inout) :: Q(ldq,*), R(ldr,*) real(real32), intent(inout) :: x(*) real(real32), intent(out) :: w(*) external scopy,sqhqr,sqrot integer info,i,k ! check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call qrupdate_xerror('SQRINR',info) return end if ! permute the columns of Q1 and rows of R1 so that c the new row ends ! up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call scopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0e0 if (j <= m) then call scopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do ! set up the 1st column do i = 1,j-1 Q(i,1) = 0e0 end do Q(j,1) = 1e0 do i = j+1,m+1 Q(i,1) = 0e0 end do ! set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0e0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do ! retriangularize R call sqhqr(m+1,n,R,ldr,w,x) ! apply rotations to Q call sqrot('F',m+1,min(m,n)+1,Q,ldq,w,x) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrot.f90000066400000000000000000000076421522610125300234020ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Applies a sequence of Givens rotations from the right to a matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrot(dir,m,n,Q,ldq,c,s) !> !> .. Scalar Arguments .. !> character dir !> integer m, n, ldq !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real c(*) !> real s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQROT applies a sequence of Givens rotations from the right !> side to an m-by-n matrix Q. Given a direction indicator !> dir, the rotation cosine and sine vectors c and s, SQROT !> applies the rotations to Q, updating it in place. If dir !> is 'F' (forward), rotations are applied from the first to !> the last; if dir is 'B' (backward), from the last to the !> first. !> \endverbatim !> !> \param[in] dir !> \verbatim !> dir is CHARACTER !> If 'B' or 'b', rotations are applied backwards !> (from the last to the first). If 'F' or 'f', !> rotations are applied forwards (from the first to !> the last). !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the matrix Q. On exit, the updated !> matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is REAL array, dimension (*) !> The rotation cosines. Must contain at least !> n-1 elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is REAL array, dimension (*) !> The rotation sines. Must contain at least !> n-1 elements. !> \endverbatim !> !> \ingroup givens subroutine sqrot(dir,m,n,Q,ldq,c,s) use iso_fortran_env use qrupdate_error use qrupdate_blas character, intent(in) :: dir integer, intent(in) :: m, n, ldq real(real32), intent(inout) :: Q(ldq,*) real(real32), intent(in) :: c(*) real(real32), intent(in) :: s(*) external srot logical fwd integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. n == 1) return ! check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call qrupdate_xerror('SQROT',info) return end if if (fwd) then do i = 1,n-1 call srot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do else do i = n-1,1,-1 call srot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrqh.f90000066400000000000000000000064321522610125300233640ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Converts an upper trapezoidal matrix to upper Hessenberg form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrqh(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> real R(ldr,*) !> real c(*) !> real s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRQH brings an upper trapezoidal matrix R into upper Hessenberg form !> using min(m-1,n) Givens rotations. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the upper Hessenberg matrix R. On exit, !> the updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is REAL array, dimension (*) !> The rotation cosines. Must contain at least !> min(m-1,n) elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is REAL array, dimension (*) !> The rotation sines. Must contain at least !> min(m-1,n) elements. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqrqh(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr real(real32), intent(inout) :: R(ldr,*) real(real32), intent(in) :: c(*) real(real32), intent(in) :: s(*) real(real32) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('SQRQH',info) return end if do i = 1,n ii = min(m-1,i) ! apply stored rotations, column-wise t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - s(j)*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrshc.f90000066400000000000000000000123031522610125300235230ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a circular shift of columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrshc(m,n,k,Q,ldq,R,ldr,i,j,w) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, i, j !> .. !> .. Array Arguments .. !> real Q(ldq,*) !> real R(ldr,*) !> real w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRSHC updates a QR factorization after circular shift of columns. !> i.e., given an m-by-k orthogonal matrix Q, an k-by-n upper !> trapezoidal matrix R and index j in the range 1:n+1, SQRSHC !> updates the matrix Q -> Q1 and R -> R1 so that Q1 is again !> orthogonal, R1 upper trapezoidal, and Q1*R1 = A(:,p), where A = Q*R !> and p is the permutation [1:i-1,shift(i:j,-1),j+1:n] if i < j or !> [1:j-1,shift(j:i,+1),i+1:n] if j < i. (real version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q1, and rows of R1. Must be !> either k = m (full Q) or k = n <= m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is REAL array, dimension (ldq,*) !> On entry, the orthogonal m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is REAL array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range (see above). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range (see above). !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (*) !> A workspace vector of size 2*k. !> \endverbatim !> !> \ingroup qrdecomp subroutine sqrshc(m,n,k,Q,ldq,R,ldr,i,j,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, i, j real(real32), intent(inout) :: Q(ldq,*), R(ldr,*) real(real32), intent(out) :: w(*) external scopy,sqrtv1,sqrqh,sqhqr,sqrot integer info,jj,kk,l ! quick return if possible. if (m == 0 .or. n == 1) return info = 0 ! check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call qrupdate_xerror('SQRSHC',info) return end if if (i < j) then ! shift columns call scopy(k,R(1,i),1,w,1) do l = i,j-1 call scopy(k,R(1,l+1),1,R(1,l),1) end do call scopy(k,w,1,R(1,j),1) ! retriangularize if (i < k) then kk = min(k,j) call sqhqr(kk+1-i,n+1-i,R(i,i),ldr,w(k+1),w) ! apply rotations to Q. call sqrot('F',m,kk+1-i,Q(1,i),ldq,w(k+1),w) end if else if (j < i) then ! shift columns call scopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call scopy(k,R(1,l-1),1,R(1,l),1) end do call scopy(k,w,1,R(1,j),1) ! retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) ! eliminate the introduced spike. call sqrtv1(kk+1-j,R(j,j),w(k+1)) ! apply rotations to R call sqrqh(kk+1-j,n-j,R(j,jj),ldr,w(k+1),R(j+1,j)) ! apply rotations to Q call sqrot('B',m,kk+1-j,Q(1,j),ldq,w(k+1),R(j+1,j)) ! zero spike. do l = j+1,kk R(l,j) = 0e0 end do end if end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/sqrtv1.f90000066400000000000000000000053471522610125300234720ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates Givens rotations to eliminate all but the first element of a vector. !> !> \par Definition: ! ============= !> \verbatim !> subroutine sqrtv1(n,u,w) !> !> .. Scalar Arguments .. !> integer n !> .. !> .. Array Arguments .. !> real u(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> SQRTV1 generates a sequence of n-1 Givens rotations that !> eliminate all but the first element of a real vector u. !> On entry, u contains the vector to be reduced. On exit, !> u(1) contains the resulting element, u(2:n) contains the !> rotation sines, and w contains the rotation cosines. !> !> The rotations are generated from the bottom up, so that the !> first rotation eliminates u(n), the second eliminates u(n-1), !> and so on. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The length of the vector u. If n <= 0, the subroutine !> returns immediately without modification. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is REAL array, dimension (n) !> On entry, the vector to be reduced. On exit, u(1) !> contains the remaining element, and u(2:n) contains !> the sine parts of the Givens rotations. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is REAL array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations. !> \endverbatim !> !> \ingroup givens subroutine sqrtv1(n,u,w) use iso_fortran_env integer, intent(in) :: n real(real32), intent(inout) :: u(*) real(real32), intent(out) :: w(*) external slartg real(real32) rr,t integer i ! quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call slartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zaxcpy.f90000066400000000000000000000077521522610125300235520ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Performs scaled conjugate vector addition. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zaxcpy(n,a,x,incx,y,incy) !> !> .. Scalar Arguments .. !> integer n, incx, incy !> .. !> .. Array Arguments .. !> double complex a, x(*), y(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZAXCPY performs the operation y := y + a * conjg(x), where a is a !> double complex scalar, x is a vector of length n, conjg(x) denotes !> the element-wise complex conjugate of x, and y is a vector of the !> same length. On entry, y contains the existing values; on exit, y !> is overwritten with the result. This is the double precision !> complex analogue of the BLAS zaxpy, with the x argument conjugated !> before scaling. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of elements in vectors x and y. If n <= 0, !> the subroutine returns immediately without modification. !> \endverbatim !> !> \param[in] a !> \verbatim !> a is COMPLEX*16 !> The double complex scalar used to scale the conjugated !> vector conjg(x) before accumulation into y. !> \endverbatim !> !> \param[in] x !> \verbatim !> x is COMPLEX*16 array, dimension (*) !> The vector of length n whose complex conjugate is scaled !> by a and added to y. x is not modified. !> \endverbatim !> !> \param[in] incx !> \verbatim !> incx is INTEGER !> The stride (increment) for elements of x. If incx > 0, !> elements are accessed starting from x(1); if incx < 0, !> elements are accessed starting from !> x(1 + (-n+1)*incx). A value of 1 accesses !> contiguous elements. !> \endverbatim !> !> \param[in,out] y !> \verbatim !> y is COMPLEX*16 array, dimension (*) !> On entry, the vector y of length n. On exit, y is !> overwritten with y + a * conjg(x). !> \endverbatim !> !> \param[in] incy !> \verbatim !> incy is INTEGER !> The stride (increment) for elements of y. If incy > 0, !> elements are accessed starting from y(1); if incy < 0, !> elements are accessed starting from !> y(1 + (-n+1)*incy). A value of 1 accesses !> contiguous elements. !> \endverbatim !> \ingroup aux subroutine zaxcpy(n,a,x,incx,y,incy) use iso_fortran_env integer, intent(in) :: n, incx, incy complex(real64), intent(in) :: a complex(real64), intent(in) :: x(*) complex(real64), intent(inout) :: y(*) integer i,ix,iy ! quick return if possible. if (n <= 0) return if (incx /= 1 .or. incy /= 1) then ! code for unequal increments or equal increments not equal to 1 ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n y(iy) = y(iy) + a*conjg(x(ix)) ix = ix + incx iy = iy + incy end do else ! code for both increments equal to 1 do i = 1,n y(i) = y(i) + a*conjg(x(i)) end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zch1dn.f90000066400000000000000000000107471522610125300234210ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Downdates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zch1dn(n,R,ldr,u,rw,info) !> !> .. Scalar Arguments .. !> integer n, ldr, info !> .. !> .. Array Arguments .. !> double complex R(ldr,*), u(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZCH1DN downdates the Cholesky factorization of a hermitian !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R'*R, where R' denotes the conjugate transpose of R, this !> ZCH1DN downdates R -> R1 so that R1'*R1 = A - u*u', where u !> is a given vector. !> !> The downdate is performed by applying a sequence of hyperbolic !> rotations to restore the upper triangular structure of R. On !> exit, u contains the rotation sines and rw contains the rotation !> cosines used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A - u*u'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX*16 array, dimension (n) !> On entry, the vector determining the rank-1 downdate. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (n) !> On exit, rw contains the cosine parts of the !> rotations used to transform R to R1. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> \endverbatim !> !> \ingroup choldecomp subroutine zch1dn(n,R,ldr,u,rw,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr complex(real64), intent(inout) :: R(ldr,*), u(*) real(real64), intent(out) :: rw(*) integer, intent(out) :: info external ztrsv,zlartg,dznrm2 complex(real64) crho,rr,ui,t real(real64) dznrm2,rho integer i,j ! quick return if possible. if (n == 0) return ! check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call qrupdate_xerror('ZCH1DN',-info) return end if ! check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do ! form R' \ u call ztrsv('U','C','N',n,R,ldr,u,1) rho = dznrm2(n,u,1) ! check positive definiteness rho = 1 - rho**2 if (rho <= 0d0) goto 10 crho = sqrt(rho) ! eliminate R' \ u do i = n,1,-1 ui = u(i) ! generate next rotation call zlartg(crho,ui,rw(i),u(i),rr) crho = rr end do ! apply rotations do i = n,1,-1 ui = 0d0 do j = i,1,-1 t = rw(j)*ui + u(j)*R(j,i) R(j,i) = rw(j)*R(j,i) - conjg(u(j))*ui ui = t end do end do ! normal return return ! error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zch1up.f90000066400000000000000000000067151522610125300234440ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zch1up(n,R,ldr,u,w) !> !> .. Scalar Arguments .. !> integer n, ldr !> .. !> .. Array Arguments .. !> double complex R(ldr,*), u(*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZCH1UP updates the Cholesky factorization of a hermitian !> positive definite matrix A after a rank-1 modification. Given an !> upper triangular matrix R that is a Cholesky factor of A, i.e., !> A = R'*R, where R' denotes the conjugate transpose of R, this !> ZCH1UP updates R -> R1 so that R1'*R1 = A + u*u', where u is !> a given vector. !> !> The update is performed by applying a sequence of Givens rotations !> to restore the upper triangular structure of R. On exit, u !> contains the rotation sines and w contains the rotation cosines !> used in the transformation. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A + u*u'. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX*16 array, dimension (n) !> On entry, the vector determining the rank-1 update. !> On exit, u contains the rotation sines used to !> transform R to R1. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations used to transform R to R1. !> \endverbatim !> !> \ingroup choldecomp subroutine zch1up(n,R,ldr,u,w) use iso_fortran_env integer, intent(in) :: n, ldr complex(real64), intent(inout) :: R(ldr,*), u(*) real(real64), intent(out) :: w(*) external zlartg complex(real64) rr,ui,t integer i,j do i = 1,n ! apply stored rotations, column-wise ui = conjg(u(i)) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - conjg(u(j))*R(j,i) R(j,i) = t end do ! generate next rotation call zlartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zchdex.f90000066400000000000000000000062541522610125300235150ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after deleting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zchdex(n,R,ldr,j,rw) !> !> .. Scalar Arguments .. !> integer n, ldr, j !> .. !> .. Array Arguments .. !> double complex R(ldr,*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZCHDEX updates the Cholesky factorization of a hermitian !> positive definite matrix A after deleting a row/column. !> Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R'*R, where R' denotes the conjugate !> transpose of R, ZCHDEX updates R -> R1 so that !> R1'*R1 = A(jj,jj), where jj = [1:j-1, j+1:n+1]. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(jj,jj). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row/column. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (n) !> A workspace vector. !> \endverbatim !> !> \ingroup choldecomp subroutine zchdex(n,R,ldr,j,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, j complex(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: rw(*) integer info,i external zcopy,zqhqr ! quick return if possible. if (n == 1) return ! check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call qrupdate_xerror('ZCHDEX',info) return end if ! delete the j-th column. do i = j,n-1 call zcopy(n,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < n) then call zqhqr(n+1-j,n-j,R(j,j),ldr,rw,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zchinx.f90000066400000000000000000000115171522610125300235310ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after inserting a row and column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zchinx(n,R,ldr,j,u,rw,info) !> !> .. Scalar Arguments .. !> integer n, j, ldr, info !> .. !> .. Array Arguments .. !> double complex R(ldr,*), u(*), rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZCHINX updates the Cholesky factorization of a hermitian !> positive definite matrix A after inserting a row and column. !> Given an upper triangular matrix R that is a Cholesky factor of !> A, i.e., A = R'*R, where R' denotes the conjugate transpose of !> R, ZCHINX updates R -> R1 so that R1'*R1 = A1, where !> A1(jj,jj) = A, A1(j,:) = u', A1(:,j) = u, and !> jj = [1:j-1, j+1:n+1]. !> !> On exit, u is destroyed and R is extended by one row and column. !> The insertion is performed by first solving R'*u = v, checking !> positive definiteness, and then retriangularizing. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n+1) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the inserted row and column. !> 1 <= j <= n+1. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX*16 array, dimension (n+1) !> On entry, the vector defining the inserted row/column. !> On exit, u is destroyed. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (n+1) !> Workspace vector used to store rotation cosines during !> the retriangularization. !> \endverbatim !> !> \param[out] info !> \verbatim !> info is INTEGER !> = 0: successful exit !> = 1: the update would violate positive-definiteness !> = 2: R is singular !> = 3: the diagonal element of u is not real !> \endverbatim !> !> \ingroup choldecomp subroutine zchinx(n,R,ldr,j,u,rw,info) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, j, ldr complex(real64), intent(inout) :: R(ldr,*), u(*) real(real64), intent(out) :: rw(*) integer, intent(out) :: info external zcopy,dznrm2,ztrsv,zqrtv1,zqrqh complex(real64) t real(real64) dznrm2,rho integer i ! check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call qrupdate_xerror('ZCHINX',info) return end if ! shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do ! the diagonal element must be real. if (imag(t) /= 0d0) goto 30 ! check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do ! form R' \ u call ztrsv('U','C','N',n,R,ldr,u,1) rho = dznrm2(n,u,1) ! check positive definiteness. rho = dble(t) - rho**2 if (rho <= 0d0) goto 10 ! shift columns do i = n,j,-1 call zcopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0d0 end do call zcopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) ! retriangularize if (j < n+1) then ! eliminate the introduced spike. call zqrtv1(n+2-j,R(j,j),rw) ! apply rotations to R call zqrqh(n+2-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) ! zero spike. do i = j+1,n+1 R(i,j) = 0d0 end do end if ! normal return. return ! error returns. 10 info = 1 return 20 info = 2 return 30 info = 3 return end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zchshx.f90000066400000000000000000000106201522610125300235270ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a Cholesky factorization after a symmetric shift of rows and columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zchshx(n,R,ldr,i,j,w,rw) !> !> .. Scalar Arguments .. !> integer n, ldr, i, j !> .. !> .. Array Arguments .. !> double complex R(ldr,*), w(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZCHSHX updates the Cholesky factorization of a hermitian !> positive definite matrix A after a symmetric shift of rows and !> columns. Given an upper triangular matrix R that is a Cholesky !> factor of A, i.e., A = R'*R, where R' denotes the conjugate !> transpose of R, ZCHSHX updates R -> R1 so that !> R1'*R1 = A(p,p), where p is the permutation !> [1:i-1, shift(i:j,-1), j+1:n] if i < j, or !> [1:j-1, shift(j:i,+1), i+1:n] if j < i. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The order of matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper triangular matrix R, the Cholesky !> factor of A. On exit, the updated upper triangular !> matrix R1, the Cholesky factor of A(p,p). !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= n. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range of the shift. !> 1 <= i <= n. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range of the shift. !> 1 <= j <= n. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX*16 array, dimension (n) !> Workspace vector used to store rotation sines during !> the retriangularization. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (n) !> Workspace vector used to store rotation cosines during !> the retriangularization. !> \endverbatim !> !> \ingroup choldecomp subroutine zchshx(n,R,ldr,i,j,w,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: n, ldr, i, j complex(real64), intent(inout) :: R(ldr,*) complex(real64), intent(out) :: w(*) real(real64), intent(out) :: rw(*) external zcopy,zqrtv1,zqrqh,zqhqr integer info,l ! quick return if possible. if (n == 0 .or. n == 1) return info = 0 ! check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call qrupdate_xerror('ZCHSHX',info) return end if if (i < j) then ! shift columns call zcopy(n,R(1,i),1,w,1) do l = i,j-1 call zcopy(n,R(1,l+1),1,R(1,l),1) end do call zcopy(n,w,1,R(1,j),1) ! retriangularize call zqhqr(n+1-i,n+1-i,R(i,i),ldr,rw,w) else if (j < i) then ! shift columns call zcopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call zcopy(n,R(1,l-1),1,R(1,l),1) end do call zcopy(n,w,1,R(1,j),1) ! eliminate the introduced spike. call zqrtv1(n+1-j,R(j,j),rw) ! apply rotations to R call zqrqh(n+1-j,n-j,R(j,j+1),ldr,rw,R(j+1,j)) ! zero spike. do l = j+1,n R(l,j) = 0d0 end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zdotc.f90000066400000000000000000000065201522610125300233470ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief ZDOTC Complex dot product (x**H y version) ! !> \par Definition: ! =========== !> \verbatim !> SUBROUTINE QRUPDATE_ZDOTC(RET, N,CX,INCX,CY,INCY) !> !> .. Scalar Arguments .. !> INTEGER INCX,INCY,N !> COMPLEX(real64) ret !> .. !> .. Array Arguments .. !> COMPLEX(real64) CX(*),CY(*) !> .. !> \endverbatim ! !> \par Purpose: ! ============= !> !> \verbatim !> !> ZDOTC forms the dot product of two complex vectors !> ZDOTC = X^H * Y !> !> \endverbatim ! ! Arguments: ! ========== ! !> \param[out] RET !> \verbatim !> RET is COMPLEX(real64) !> RET contains the dot product. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> number of elements in input vector(s) !> \endverbatim !> !> \param[in] CX !> \verbatim !> CX is COMPLEX(real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> storage spacing between elements of CX !> \endverbatim !> !> \param[in] CY !> \verbatim !> CY is COMPLEX(real64) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> storage spacing between elements of CY !> \endverbatim ! !> \remark This routine is equivalent to zdotc from BLAS but invariant with the compiler's Fortran ABI ! !> \ingroup aux ! ===================================================================== subroutine qrupdate_zdotc(ret,n,cx,incx,cy,incy) use iso_fortran_env implicit none ! .. scalar arguments .. integer, intent(in) :: incx,incy,n ! .. ! .. array arguments .. complex(real64), intent(in) :: cx(*),cy(*) complex(real64), intent(out) :: ret ! .. ! ! .. local scalars .. complex(real64) ctemp integer i,ix,iy ! .. ctemp = (0.0,0.0) ret = (0.0,0.0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ctemp = ctemp + conjg(cx(i))*cy(i) end do else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = ctemp + conjg(cx(ix))*cy(iy) ix = ix + incx iy = iy + incy end do end if ret = ctemp return ! ! end of zdotc ! end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zdotu.f90000066400000000000000000000064741522610125300234010ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Complex dot product (x**T y version) ! !> \par Definition: ! =========== !> \verbatim !> SUBROUTINE QRUPDATE_ZDOTU(RET, N,CX,INCX,CY,INCY) !> !> .. Scalar Arguments .. !> INTEGER INCX,INCY,N !> COMPLEX(real32) ret !> .. !> .. Array Arguments .. !> COMPLEX(real32) CX(*),CY(*) !> .. !> \endverbatim ! !> \par Purpose: ! ============= !> !> \verbatim !> !> ZDOTU forms the dot product of two complex vectors !> ZDOTU = X^T * Y !> !> \endverbatim ! ! Arguments: ! ========== ! !> \param[out] RET !> \verbatim !> RET is COMPLEX(real32) !> RET contains the dot product. !> \endverbatim !> !> \param[in] N !> \verbatim !> N is INTEGER !> number of elements in input vector(s) !> \endverbatim !> !> \param[in] CX !> \verbatim !> CX is COMPLEX(real32) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !> \endverbatim !> !> \param[in] INCX !> \verbatim !> INCX is INTEGER !> storage spacing between elements of CX !> \endverbatim !> !> \param[in] CY !> \verbatim !> CY is COMPLEX(real32) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !> \endverbatim !> !> \param[in] INCY !> \verbatim !> INCY is INTEGER !> storage spacing between elements of CY !> \endverbatim !> !> \remark This routine is equivalent to zdotu from BLAS but invariant with the compiler's Fortran ABI !> !> \ingroup aux ! ===================================================================== subroutine qrupdate_zdotu(ret,n,cx,incx,cy,incy) use iso_fortran_env implicit none ! .. scalar arguments .. integer, intent(in) :: incx,incy,n ! .. ! .. array arguments .. complex(real32), intent(in) :: cx(*),cy(*) complex(real32), intent(out) :: ret ! .. ! ! .. local scalars .. complex(real32) ctemp integer i,ix,iy ! .. ctemp = (0.0,0.0) ret = (0.0,0.0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ctemp = ctemp + cx(i)*cy(i) end do else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = ctemp + cx(ix)*cy(iy) ix = ix + incx iy = iy + incy end do end if ret = ctemp return ! ! end of zdotu ! end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zgqvec.f90000066400000000000000000000075511522610125300235300ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates a unit vector orthogonal to the column space of a unitary matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zgqvec(m,n,Q,ldq,u) !> !> .. Scalar Arguments .. !> integer m, n, ldq !> .. !> .. Array Arguments .. !> double complex Q(ldq,*), u(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZGQVEC generates a vector u in the orthogonal complement of the !> column space of a unitary matrix Q. Given an m-by-n unitary !> matrix Q with n < m, ZGQVEC generates a vector u of !> length m such that Q'*u = 0 and norm(u) = 1, where Q' denotes !> the conjugate transpose of Q. !> !> The algorithm projects canonical unit vectors onto the orthogonal !> complement of Q's column space until a nonzero result is found. !> If n = 0, the first canonical unit vector is returned. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0 and !> n < m. !> \endverbatim !> !> \param[in] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,n) !> The unitary m-by-n matrix Q. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of the array Q. ldq >= m. !> \endverbatim !> !> \param[out] u !> \verbatim !> u is COMPLEX*16 array, dimension (m) !> The generated vector such that Q'*u = 0 and norm(u) = 1. !> \endverbatim !> !> \ingroup qrdecomp subroutine zgqvec(m,n,Q,ldq,u) use iso_fortran_env use qrupdate_blas use qrupdate_error integer, intent(in) :: m, n, ldq complex(real64), intent(in) :: Q(ldq,*) complex(real64), intent(out) :: u(*) external zaxpy,dznrm2,zdscal real(real64) dznrm2,r complex(real64) rc integer info,i,j ! quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1d0 do i = 2,m u(i) = 0d0 end do return end if ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('ZGQVEC',info) return end if j = 1 r = 0d0 do while ( r .eq. 0d0) ! probe j-th canonical unit vector. do i = 1,m u(i) = 0d0 end do u(j) = 1d0 ! form u - Q*Q'*u do i = 1,n call qrupdate_zdotc(rc, m,Q(1,i),1,u,1) call zaxpy(m,-rc,Q(1,i),1,u,1) end do r = dznrm2(m,u,1) if (r == 0d0) then j = j + 1 if (j > n) then ! this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in ZGQVEC' end if end if end do call zdscal(m,1d0/r,u,1) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zlu1up.f90000066400000000000000000000114021522610125300234570ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates an LU factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zlu1up(m,n,L,ldl,R,ldr,u,v) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> double complex L(ldl,*), R(ldr,*), u(*), v(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZLU1UP updates an LU factorization after rank-1 modification. !> Given an m-by-k lower-triangular matrix L with unit diagonal and !> a k-by-n upper-trapezoidal matrix R, where k = min(m,n), this !> ZLU1UP updates L -> L1 and R -> R1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, and !> L1*R1 = L*R + u*v', where v' denotes the conjugate transpose !> of v. !> !> The update is performed using the Bennett algorithm with !> column-major access, which processes the leading k-by-k block !> first and then finishes the trailing part of R if needed. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is COMPLEX*16 array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX*16 array, dimension (m) !> On entry, the left m-vector defining the rank-1 !> modification. On exit, if k < m, u is destroyed; !> otherwise, u contains the updated vector. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is COMPLEX*16 array, dimension (n) !> On entry, the right n-vector defining the rank-1 !> modification. On exit, v is destroyed. !> \endverbatim !> !> \ingroup ludecomp subroutine zlu1up(m,n,L,ldl,R,ldr,u,v) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr complex(real64), intent(inout) :: L(ldl,*), R(ldr,*) complex(real64), intent(inout) :: u(*), v(*) complex(real64) ui,vi integer k,info,i,j ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('ZLU1UP',info) return end if ! The Bennett algorithm, modified for column-major access. ! The leading part. do i = 1,k ! prefetch ui = u(i) vi = v(i) ! delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do ! diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) ! L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do ! Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zlup1up.f90000066400000000000000000000155531522610125300236520ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a row-pivoted LU factorization after rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zlup1up(m,n,L,ldl,R,ldr,p,u,v,w) !> !> .. Scalar Arguments .. !> integer m, n, ldl, ldr !> .. !> .. Array Arguments .. !> integer p(*) !> double complex L(ldl,*), R(ldr,*), u(*), v(*), w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZLUP1UP updates a row-pivoted LU factorization after rank-1 !> modification. Given an m-by-k lower-triangular matrix L with !> unit diagonal, a k-by-n upper-trapezoidal matrix R, and a !> permutation vector p, where k = min(m,n), ZLUP1UP !> updates L -> L1, R -> R1 and p -> p1 so that L1 is again !> lower unit triangular, R1 upper trapezoidal, p1 a permutation, !> and P1'*L1*R1 = P'*L*R + u*v', where v' denotes the conjugate !> transpose of v and P is the permutation matrix corresponding !> to p. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix L. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] L !> \verbatim !> L is COMPLEX*16 array, dimension (ldl,k) !> On entry, the unit lower triangular matrix L. On exit, !> the updated unit lower triangular matrix L1. !> \endverbatim !> !> \param[in] ldl !> \verbatim !> ldl is INTEGER !> The leading dimension of the array L. ldl >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper trapezoidal m-by-n matrix R. !> On exit, the updated upper trapezoidal matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= k, !> where k = min(m,n). !> \endverbatim !> !> \param[in] p !> \verbatim !> p is INTEGER array, dimension (m) !> The permutation vector representing the row pivoting. !> On exit, p is updated to reflect the new pivoting. !> \endverbatim !> !> \param[in] u !> \verbatim !> u is COMPLEX*16 array, dimension (m) !> The left m-vector defining the rank-1 modification. !> \endverbatim !> !> \param[in] v !> \verbatim !> v is COMPLEX*16 array, dimension (n) !> The right n-vector defining the rank-1 modification. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX*16 array, dimension (m) !> Workspace vector used during the update computation. !> \endverbatim !> !> \ingroup ludecomp subroutine zlup1up(m,n,L,ldl,R,ldr,p,u,v,w) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldl, ldr integer, intent(inout) :: p(*) complex(real64), intent(inout) :: L(ldl,*), R(ldr,*) complex(real64), intent(in) :: u(*), v(*) complex(real64), intent(out) :: w(*) complex(real64) one,tmp real(real64) tau parameter (one = 1d0, tau = 1d-1) integer k,info,i,j,itmp external zcopy,zaxpy,ztrsv,zgeru,zgemv,zswap ! quick return if possible. k = min(m,n) if (k == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call qrupdate_xerror('ZLUP1UP',info) return end if ! form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call ztrsv('L','N','U',k,L,ldl,w,1) ! if m > k = n, subtract the trailing part. if (m > k) then call zgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if ! work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then ! need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call zswap(m-j+1,L(j,j),1,L(j,j+1),1) call zswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call zswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call zaxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call zaxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) ! update w w(j) = w(j) - tmp*w(j+1) end if ! eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 ! update R. call zaxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) ! update L. call zaxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! add a multiple of v to R call zaxpy(n,w(1),v,1,R(1,1),ldr) ! forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then ! need pivoting. swap j and j+1 ! update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp ! update L call zswap(m-j+1,L(j,j),1,L(j,j+1),1) call zswap(j+1,L(j,1),ldl,L(j+1,1),ldl) ! update R call zswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) ! make L lower triangular again tmp = -L(j,j+1) call zaxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) ! update R call zaxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if ! eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) ! update R. R(j+1,j) = 0d0 call zaxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) ! update L. call zaxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do ! if m > k = n, complete the update by updating the lower part of L. if (m > k) then call zcopy(k,v,1,w,1) call ztrsv('U','T','N',k,R,ldr,w,1) call zgeru(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqhqr.f90000066400000000000000000000075071522610125300233770ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Reduces an upper Hessenberg matrix to upper trapezoidal form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqhqr(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> double complex R(ldr,*), s(*) !> double precision c(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQHQR reduces an m-by-n upper Hessenberg matrix R to upper !> trapezoidal form. Given an m-by-n upper Hessenberg matrix R, !> ZQHQR applies min(m-1,n) Givens rotations from the !> left to eliminate the subdiagonal elements, producing an upper !> trapezoidal matrix. !> !> On exit, c contains the cosine parts and s contains the sine !> parts of the Givens rotations used in the reduction. !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,n) !> On entry, the upper Hessenberg matrix R. On exit, the !> updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of the array R. ldr >= m. !> \endverbatim !> !> \param[out] c !> \verbatim !> c is DOUBLE PRECISION array, dimension (min(m-1,n)) !> On exit, the cosine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \param[out] s !> \verbatim !> s is COMPLEX*16 array, dimension (min(m-1,n)) !> On exit, the sine parts of the Givens rotations used !> to reduce R to upper trapezoidal form. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqhqr(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr complex(real64), intent(inout) :: R(ldr,*) real(real64), intent(out) :: c(*) complex(real64), intent(out) :: s(*) external zlartg complex(real64) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('ZQHQR',info) return end if do i = 1,n ! apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - conjg(s(j))*t end do if (ii < m) then ! generate next rotation call zlartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0d0 else R(ii,i) = t end if end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqr1up.f90000066400000000000000000000127671522610125300235000ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a rank-1 modification. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqr1up(m,n,k,Q,ldq,R,ldr,u,v,w,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double complex R(ldr,*) !> double complex u(*) !> double complex v(*) !> double complex w(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQR1UP updates a QR factorization after rank-1 modification i.e., !> given a m-by-k unitary Q and m-by-n upper trapezoidal R, an m-vector !> u and n-vector v, ZQR1UP updates Q -> Q1 and R -> R1 so that !> Q1*R1 = Q*R + u*v', and Q1 is again unitary and R1 upper trapezoidal. !> (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n < m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the upper trapezoidal m-by-n matrix R. On !> exit, the updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX*16 array, dimension (*) !> On entry, the left m-vector. On exit, if k < m, !> u is destroyed. !> \endverbatim !> !> \param[in,out] v !> \verbatim !> v is COMPLEX*16 array, dimension (*) !> On entry, the right n-vector. On exit, v is !> destroyed. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX*16 array, dimension (*) !> A workspace vector of size k. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (*) !> A real workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqr1up(m,n,k,Q,ldq,R,ldr,u,v,w,rw) use iso_fortran_env use qrupdate_blas use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr complex(real64), intent(inout) :: Q(ldq,*), R(ldr,*), u(*), v(*) complex(real64), intent(out) :: w(*) real(real64), intent(out) :: rw(*) external zqrqh,zqhqr,zqrot,zqrtv1,zaxpy,zaxcpy, zch1up external dznrm2,dlamch,zdscal,zrot real(real64) dznrm2,dlamch,ru,ruu integer info,i logical full ! quick return if possible. if (k == 0 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call qrupdate_xerror('ZQR1UP',info) return end if full = k == m ru = 1.0d0 ! in the non-full case, we shall need the norm of u. if (.not.full) ru = dznrm2(m,u,1) ! form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k call qrupdate_zdotc(w(i), m,Q(1,i),1,u,1) if (.not.full) call zaxpy(m,-w(i),Q(1,i),1,u,1) end do ! generate rotations to eliminate Q'*u. call zqrtv1(k,w,rw) ! apply rotations to R. call zqrqh(k,n,R,ldr,rw,w(2)) ! apply rotations to Q. call zqrot('B',m,k,Q,ldq,rw,w(2)) ! update the first row of R. call zaxcpy(n,w(1),v,1,R(1,1),ldr) ! retriangularize R. call zqhqr(k,n,R,ldr,rw,w) ! apply rotations to Q. call zqrot('F',m,min(k,n+1),Q,ldq,rw,w) ! in the full case, we're finished if (full) return ! compute relative residual norm ruu = dznrm2(m,u,1) ru = ru * dlamch('e') if (ruu <= ru) return ! update the orthogonal basis. call zdscal(n,ruu,v,1) call zdscal(m,1d0/ruu,u,1) call zch1up(n,R,ldr,v,rw) do i = 1,n call zrot(m,Q(1,i),1,u,1,rw(i),conjg(v(i))) end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrdec.f90000066400000000000000000000103071522610125300235120ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrdec(m,n,k,Q,ldq,R,ldr,j,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double complex R(ldr,*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRDEC updates a QR factorization after deleting a column. i.e., !> given an m-by-k unitary matrix Q, an k-by-n upper trapezoidal matrix !> R and index j in the range 1:n+1, ZQRDEC updates the matrix !> Q -> Q1 and R -> R1 so that Q1 remains unitary, R1 is upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], where A = Q*R. !> (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> (full Q) or k = n < m (economical form, basis dimension will !> decrease). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted column in R. 1 <= j <= n. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (*) !> A real workspace vector of size k-j. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqrdec(m,n,k,Q,ldq,R,ldr,j,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j complex(real64), intent(inout) :: Q(ldq,*), R(ldr,*) real(real64), intent(out) :: rw(*) external zcopy,zqhqr,zqrot integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('ZQRDEC',info) return end if ! delete the j-th column. do i = j,n-1 call zcopy(k,R(1,i+1),1,R(1,i),1) end do ! retriangularize. if (j < k) then call zqhqr(k+1-j,n-j,R(j,j),ldr,rw,R(1,n)) ! apply rotations to Q. call zqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,rw,R(1,n)) end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrder.f90000066400000000000000000000101651522610125300235330ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after deleting a row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrder(m,n,Q,ldq,R,ldr,j,w,rw) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double complex R(ldr,*) !> double complex w(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRDER updates a QR factorization after deleting a row. i.e., given !> an m-by-m unitary matrix Q, an m-by-n upper trapezoidal matrix R and !> index j in the range 1:m, ZQRDER updates Q ->Q1 and an R -> !> R1 so that Q1 is again unitary, R1 upper trapezoidal, and Q1*R1 = !> [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the unitary matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the deleted row. 1 <= j <= m. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX*16 array, dimension (*) !> A workspace vector of size m. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (*) !> A real workspace vector of size m. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqrder(m,n,Q,ldq,R,ldr,j,w,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldq, ldr, j complex(real64), intent(inout) :: Q(ldq,*), R(ldr,*) complex(real64), intent(out) :: w(*) real(real64), intent(out) :: rw(*) external zcopy,zqrtv1,zqrot,zqrqh integer info,i,k ! quick return if possible. if (m == 1) return ! check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call qrupdate_xerror('ZQRDER',info) return end if ! eliminate Q(j,2:m). do k = 1,m w(k) = conjg(Q(j,k)) end do call zqrtv1(m,w,rw) ! apply rotations to Q. call zqrot('B',m,m,Q,ldq,rw,w(2)) ! form Q1. do k = 1,m-1 if (j > 1) call zcopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call zcopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do ! apply rotations to R. call zqrqh(m,n,R,ldr,rw,w(2)) ! form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrinc.f90000066400000000000000000000133141522610125300235310ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new column. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrinc(m,n,k,Q,ldq,R,ldr,j,x,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, j !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double complex R(ldr,*) !> double complex x(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRINC updates a QR factorization after inserting a new column. i.e., !> given an m-by-k unitary matrix Q, an m-by-n upper trapezoidal matrix !> R and index j in the range 1:n+1, ZQRINC updates the matrix !> Q -> Q1 and R -> R1 so that Q1 is again unitary, R1 upper !> trapezoidal, and Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], where A = Q*R. !> (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q, and rows of R. Must be !> either k = m (full Q) or k = n <= m (economical form, !> basis dimension will increase). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= min(m,n+1). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new column in R1. 1 <= j <= n+1. !> \endverbatim !> !> \param[in] x !> \verbatim !> x is COMPLEX*16 array, dimension (*) !> The column being inserted. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (*) !> A real workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqrinc(m,n,k,Q,ldq,R,ldr,j,x,rw) use iso_fortran_env use qrupdate_blas use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, j complex(real64), intent(inout) :: Q(ldq,*), R(ldr,*) complex(real64), intent(in) :: x(*) real(real64), intent(out) :: rw(*) external zqrtv1,zqrqh,zqrot,zgqvec external zcopy,zaxpy,zdscal,dznrm2 real(real64) dznrm2,rx integer info,i,k1 logical full ! quick return if possible. if (m == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call qrupdate_xerror('ZQRINC',info) return end if full = k == m ! insert empty column at j-th position do i = n,j,-1 call zcopy(k,R(1,i),1,R(1,i+1),1) end do ! insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k call qrupdate_zdotc(R(i,j), m,Q(1,i),1,x,1) end do else k1 = k + 1 ! zero last row of R do i = 1,n+1 R(k1,i) = 0d0 end do call zcopy(m,x,1,Q(1,k1),1) do i = 1,k call qrupdate_zdotc(R(i,j), m,Q(1,i),1,Q(1,k1),1) call zaxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do ! get norm of the inserted column rx = dznrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0d0) then ! in the rare case when rx is exact zero, we still need to provide ! a valid orthogonal unit vector. The details are boring, so handle ! that elsewhere. call zgqvec(m,k,Q,ldq,Q(1,k1)) else ! otherwise, just normalize the added column. call zdscal(m,1d0/rx,Q(1,k1),1) end if end if ! maybe we're finished. if (j > k) return ! eliminate the spike. call zqrtv1(k1+1-j,R(j,j),rw) ! apply rotations to R(j:k,j:n). if (j <= n) call zqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) ! apply rotations to Q(:,j:k). call zqrot('B',m,k1+1-j,Q(1,j),ldq,rw,R(j+1,j)) ! zero spike. do i = j+1,k1 R(i,j) = 0d0 end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrinr.f90000066400000000000000000000106201522610125300235450ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after inserting a new row. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrinr(m,n,Q,ldq,R,ldr,j,x,rw) !> !> .. Scalar Arguments .. !> integer m, n, ldq, ldr, j !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double complex R(ldr,*) !> double complex x(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRINR updates a QR factorization after inserting a new row. i.e., !> given an m-by-m unitary matrix Q, an m-by-n upper trapezoidal matrix !> R and index j in the range 1:m+1, ZQRINR updates Q -> Q1 and !> R -> R1 so that Q1 is again unitary, R1 upper trapezoidal, and Q1*R1 !> = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the unitary matrix Q. On exit, the !> updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m+1. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m+1. !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The position of the new row in R1. 1 <= j <= m+1. !> \endverbatim !> !> \param[in,out] x !> \verbatim !> x is COMPLEX*16 array, dimension (*) !> On entry, the row being added. On exit, x is !> destroyed. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (*) !> A real workspace vector of size min(m,n). !> \endverbatim !> !> \ingroup qrdecomp subroutine zqrinr(m,n,Q,ldq,R,ldr,j,x,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, j, ldq, ldr complex(real64), intent(inout) :: Q(ldq,*), R(ldr,*), x(*) real(real64), intent(out) :: rw(*) external zcopy,zqhqr,zqrot integer info,i,k ! check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call qrupdate_xerror('ZQRINR',info) return end if ! permute the columns of Q1 and rows of R1 so that c the new row ends ! up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call zcopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0d0 if (j <= m) then call zcopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do ! set up the 1st column do i = 1,j-1 Q(i,1) = 0d0 end do Q(j,1) = 1d0 do i = j+1,m+1 Q(i,1) = 0d0 end do ! set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0d0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do ! retriangularize R call zqhqr(m+1,n,R,ldr,rw,x) ! apply rotations to Q call zqrot('F',m+1,min(m,n)+1,Q,ldq,rw,x) end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrot.f90000066400000000000000000000077151522610125300234120ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Applies a sequence of Givens rotations from the right to a matrix. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrot(dir,m,n,Q,ldq,c,s) !> !> .. Scalar Arguments .. !> character dir !> integer m, n, ldq !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double precision c(*) !> double complex s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQROT applies a sequence of Givens rotations from the right !> side to an m-by-n matrix Q. Given a direction indicator !> dir, the rotation cosine and sine vectors c and s, ZQROT !> applies the rotations to Q, updating it in place. If dir !> is 'F' (forward), rotations are applied from the first to !> the last; if dir is 'B' (backward), from the last to the !> first. !> \endverbatim !> !> \param[in] dir !> \verbatim !> dir is CHARACTER !> If 'B' or 'b', rotations are applied backwards !> (from the last to the first). If 'F' or 'f', !> rotations are applied forwards (from the first to !> the last). !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix Q. n >= 0. !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the matrix Q. On exit, the updated !> matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is DOUBLE PRECISION array, dimension (*) !> The rotation cosines. Must contain at least !> n-1 elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is COMPLEX*16 array, dimension (*) !> The rotation sines. Must contain at least !> n-1 elements. !> \endverbatim !> !> \ingroup givens subroutine zqrot(dir,m,n,Q,ldq,c,s) use iso_fortran_env use qrupdate_error use qrupdate_blas character, intent(in) :: dir integer, intent(in) :: m, n, ldq complex(real64), intent(inout) :: Q(ldq,*) real(real64), intent(in) :: c(*) complex(real64), intent(in) :: s(*) external zrot logical fwd integer info,i ! quick return if possible. if (m == 0 .or. n == 0 .or. n == 1) return ! check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call qrupdate_xerror('ZQROT',info) return end if if (fwd) then do i = 1,n-1 call zrot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do else do i = n-1,1,-1 call zrot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrqh.f90000066400000000000000000000065051522610125300233740ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Converts an upper trapezoidal matrix to upper Hessenberg form. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrqh(m,n,R,ldr,c,s) !> !> .. Scalar Arguments .. !> integer m, n, ldr !> .. !> .. Array Arguments .. !> double complex R(ldr,*) !> double precision c(*) !> double complex s(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRQH brings an upper trapezoidal matrix R into upper Hessenberg form !> using min(m-1,n) Givens rotations. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix R. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the upper Hessenberg matrix R. On exit, !> the updated upper trapezoidal matrix. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= m. !> \endverbatim !> !> \param[in] c !> \verbatim !> c is DOUBLE PRECISION array, dimension (*) !> The rotation cosines. Must contain at least !> min(m-1,n) elements. !> \endverbatim !> !> \param[in] s !> \verbatim !> s is COMPLEX*16 array, dimension (*) !> The rotation sines. Must contain at least !> min(m-1,n) elements. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqrqh(m,n,R,ldr,c,s) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, ldr complex(real64), intent(inout) :: R(ldr,*) real(real64), intent(in) :: c(*) complex(real64), intent(in) :: s(*) complex(real64) t integer info,i,ii,j ! quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return ! check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call qrupdate_xerror('ZQRQH',info) return end if do i = 1,n ii = min(m-1,i) ! apply stored rotations, column-wise t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - conjg(s(j))*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrshc.f90000066400000000000000000000126501522610125300235370ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Updates a QR factorization after a circular shift of columns. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrshc(m,n,k,Q,ldq,R,ldr,i,j,w,rw) !> !> .. Scalar Arguments .. !> integer m, n, k, ldq, ldr, i, j !> .. !> .. Array Arguments .. !> double complex Q(ldq,*) !> double complex R(ldr,*) !> double complex w(*) !> double precision rw(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRSHC updates a QR factorization after circular shift of columns. !> i.e., given an m-by-k unitary matrix Q, an k-by-n upper trapezoidal !> matrix R and index j in the range 1:n+1, ZQRSHC updates the !> matrix Q -> Q1 and R -> R1 so that Q1 is again unitary, R1 upper !> trapezoidal, and Q1*R1 = A(:,p), where A = Q*R and p is the !> permutation [1:i-1,shift(i:j,-1),j+1:n] if i < j or !> [1:j-1,shift(j:i,+1),i+1:n] if j < i. (complex version) !> \endverbatim !> !> \param[in] m !> \verbatim !> m is INTEGER !> The number of rows of the matrix Q. m >= 0. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The number of columns of the matrix R. n >= 0. !> \endverbatim !> !> \param[in] k !> \verbatim !> k is INTEGER !> The number of columns of Q1, and rows of R1. Must be !> either k = m (full Q) or k = n <= m (economical form). !> \endverbatim !> !> \param[in,out] Q !> \verbatim !> Q is COMPLEX*16 array, dimension (ldq,*) !> On entry, the unitary m-by-k matrix Q. On exit, !> the updated matrix Q1. !> \endverbatim !> !> \param[in] ldq !> \verbatim !> ldq is INTEGER !> The leading dimension of Q. ldq >= m. !> \endverbatim !> !> \param[in,out] R !> \verbatim !> R is COMPLEX*16 array, dimension (ldr,*) !> On entry, the original matrix R. On exit, the !> updated matrix R1. !> \endverbatim !> !> \param[in] ldr !> \verbatim !> ldr is INTEGER !> The leading dimension of R. ldr >= k. !> \endverbatim !> !> \param[in] i !> \verbatim !> i is INTEGER !> The first index determining the range (see above). !> \endverbatim !> !> \param[in] j !> \verbatim !> j is INTEGER !> The second index determining the range (see above). !> \endverbatim !> !> \param[out] w !> \verbatim !> w is COMPLEX*16 array, dimension (*) !> A workspace vector of size k. !> \endverbatim !> !> \param[out] rw !> \verbatim !> rw is DOUBLE PRECISION array, dimension (*) !> A real workspace vector of size k. !> \endverbatim !> !> \ingroup qrdecomp subroutine zqrshc(m,n,k,Q,ldq,R,ldr,i,j,w,rw) use iso_fortran_env use qrupdate_error integer, intent(in) :: m, n, k, ldq, ldr, i, j complex(real64), intent(inout) :: Q(ldq,*), R(ldr,*) complex(real64), intent(out) :: w(*) real(real64), intent(out) :: rw(*) external zcopy,zqrtv1,zqrqh,zqhqr,zqrot integer info,jj,kk,l ! quick return if possible. if (m == 0 .or. n == 1) return info = 0 ! check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call qrupdate_xerror('ZQRSHC',info) return end if if (i < j) then ! shift columns call zcopy(k,R(1,i),1,w,1) do l = i,j-1 call zcopy(k,R(1,l+1),1,R(1,l),1) end do call zcopy(k,w,1,R(1,j),1) ! retriangularize if (i < k) then kk = min(k,j) call zqhqr(kk+1-i,n+1-i,R(i,i),ldr,rw,w) ! apply rotations to Q. call zqrot('F',m,kk+1-i,Q(1,i),ldq,rw,w) end if else if (j < i) then ! shift columns call zcopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call zcopy(k,R(1,l-1),1,R(1,l),1) end do call zcopy(k,w,1,R(1,j),1) ! retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) ! eliminate the introduced spike. call zqrtv1(kk+1-j,R(j,j),rw) ! apply rotations to R call zqrqh(kk+1-j,n-j,R(j,jj),ldr,rw,R(j+1,j)) ! apply rotations to Q call zqrot('B',m,kk+1-j,Q(1,j),ldq,rw,R(j+1,j)) ! zero spike. do l = j+1,kk R(l,j) = 0d0 end do end if end if end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/src/zqrtv1.f90000066400000000000000000000054331522610125300234750ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Generates Givens rotations to eliminate all but the first element of a vector. !> !> \par Definition: ! ============= !> \verbatim !> subroutine zqrtv1(n,u,w) !> !> .. Scalar Arguments .. !> integer n !> .. !> .. Array Arguments .. !> double complex u(*) !> double precision w(*) !> .. !> \endverbatim !> !> \par Purpose: ! ============= !> \verbatim !> !> ZQRTV1 generates a sequence of n-1 Givens rotations that !> eliminate all but the first element of a double complex !> vector u. On entry, u contains the vector to be reduced. !> On exit, u(1) contains the remaining element, u(2:n) contains !> the rotation sines, and w contains the rotation cosines. !> !> The rotations are generated from the bottom up, so that the !> first rotation eliminates u(n), the second eliminates u(n-1), !> and so on. !> \endverbatim !> !> \param[in] n !> \verbatim !> n is INTEGER !> The length of the vector u. If n <= 0, the subroutine !> returns immediately without modification. !> \endverbatim !> !> \param[in,out] u !> \verbatim !> u is COMPLEX*16 array, dimension (n) !> On entry, the vector to be reduced. On exit, u(1) !> contains the remaining element, and u(2:n) contains !> the sine parts of the Givens rotations. !> \endverbatim !> !> \param[out] w !> \verbatim !> w is DOUBLE PRECISION array, dimension (n) !> On exit, w contains the cosine parts of the Givens !> rotations. !> \endverbatim !> !> \ingroup givens subroutine zqrtv1(n,u,w) use iso_fortran_env integer, intent(in) :: n complex(real64), intent(inout) :: u(*) real(real64), intent(out) :: w(*) external zlartg complex(real64) rr,t integer i ! quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call zlartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/000077500000000000000000000000001522610125300220715ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/CMakeLists.txt000066400000000000000000000073661522610125300246450ustar00rootroot00000000000000SET(UTILS_SRC utils.f90 test_state.f90) IF (NOT BUILD_SHARED_LIBS) SET(QRUPDATE_TARGET qrupdate::qrupdate_static) else() SET(QRUPDATE_TARGET qrupdate::qrupdate) ENDIF() ADD_LIBRARY(utils STATIC ${UTILS_SRC}) target_link_libraries(utils PUBLIC ${QRUPDATE_TARGET}) ADD_COVERAGE(utils) SET(TEST_PRGM tch1dn tch1up tchdex tchinx tchshx tlu1up tlup1up tqr1up tqrdec tqrder tqrinc tqrinr tqrshc test_qrupdate_error test_qrupdate_validation tgqvec ) IF ( CMAKE_CROSSCOMPILING AND CMAKE_SYSTEM_NAME MATCHES Windows ) FIND_PROGRAM(WINE_CMD wine HINTS /usr/bin /usr/local/bin ENV WINEROOT ) if (NOT WINE_CMD) MESSAGE(FATAL_ERROR "Wine not found. Consider setting WINEROOT") endif() set(CMAKE_CROSSCOMPILING_EMULATOR "${WINE_CMD}") SET(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${Fortran_LOCAL_FLAGS}") # FIND_PROGRAM(WINE NAMES wine wine32 wine64) # IF ( NOT WINE ) # MESSAGE(FATAL_ERROR "Wine not found") # ELSE() # MESSAGE(STATUS "Wine found: ${WINE}") # ENDIF() EXECUTE_PROCESS(COMMAND ${CMAKE_C_COMPILER} -print-search-dirs COMMAND grep programs COMMAND cut -d= -f2 COMMAND sed -e "s/:/;/g" COMMAND tr -d "\n" OUTPUT_VARIABLE WINEPATH_TMP) SET(WINEPATH) SET(ENVPATH_TMP "$ENV{WINEPATH}") FOREACH ( P IN LISTS ENVPATH_TMP) execute_process(COMMAND winepath -0 -w ${P} OUTPUT_VARIABE PX ERROR_QUIET) # message(STATUS "PX: ${PX}") SET(WINEPATH "${WINEPATH}\\;${PX}") ENDFOREACH() FOREACH ( P IN LISTS CMAKE_FIND_ROOT_PATH ) execute_process(COMMAND winepath -0 -w ${P}/bin OUTPUT_VARIABLE PX ERROR_QUIET) # message(STATUS "PX: ${PX}") SET(WINEPATH "${WINEPATH}\\;${PX}") execute_process(COMMAND winepath -0 -w ${P}/lib OUTPUT_VARIABLE PX ERROR_QUIET) # message(STATUS "PX: ${PX}") SET(WINEPATH "${WINEPATH}\\;${PX}") ENDFOREACH() FOREACH ( P IN LISTS WINEPATH_TMP ) execute_process(COMMAND winepath -0 -w ${P} OUTPUT_VARIABLE PX ERROR_QUIET) # message(STATUS "PX: ${PX}") SET(WINEPATH "${WINEPATH}\\;${PX}") ENDFOREACH() execute_process(COMMAND winepath -0 -w ${CMAKE_BINARY_DIR}/src OUTPUT_VARIABLE PX ERROR_QUIET) SET(WINEPATH "${PX}\\;${WINEPATH}") MESSAGE(STATUS "Setting WINEPATH for tests to ${WINEPATH}") ENDIF() IF (CMAKE_SYSTEM_NAME MATCHES "CYGWIN") MESSAGE(STATUS "CYGWIN build") MESSAGE("Set additional PATH for tests to ${CMAKE_BINARY_DIR}/src:/usr/lib/lapack") SET(ADDPATH "${CMAKE_BINARY_DIR}/src:/usr/lib/lapack") ENDIF() FOREACH(TEST_CODE ${TEST_PRGM}) ADD_EXECUTABLE(${TEST_CODE} ${TEST_CODE}.f90) ADD_COVERAGE(${TEST_CODE}) TARGET_LINK_LIBRARIES(${TEST_CODE} utils ${QRUPDATE_TARGET} LAPACK::LAPACK BLAS::BLAS ) if (APPLE) SET_TARGET_PROPERTIES(${TEST_CODE} PROPERTIES LINK_FLAGS "-flat_namespace") endif() # set_target_properties(${TEST_CODE} PROPERTIES CROSSCOMPILING_EMULATOR "/usr/bin/wine") IF ( CMAKE_CROSSCOMPILING ) IF ( CMAKE_SYSTEM_NAME MATCHES Windows) ADD_TEST(NAME test_${TEST_CODE} COMMAND ${TEST_CODE}) SET_TESTS_PROPERTIES(test_${TEST_CODE} PROPERTIES ENVIRONMENT "WINEPATH=${WINEPATH}") # SET_TESTS_PROPERTIES(test_${TEST_CODE} PROPERTIES CROSSCOMPILING_EMULATOR "/usr/bin/wine") ELSE() MESSAGE(WARNING "Cross-Compile checks are only possible from Linux to Windows.") ENDIF() ELSE () ADD_TEST(NAME test_${TEST_CODE} COMMAND ${TEST_CODE}) IF ( ADDPATH ) SET_TESTS_PROPERTIES(test_${TEST_CODE} PROPERTIES ENVIRONMENT "PATH=${ADDPATH}:$ENV{PATH}") ENDIF() ENDIF() ENDFOREACH() qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/report_results000077500000000000000000000007301522610125300251130ustar00rootroot00000000000000#!/bin/sh OUTS=$* passed_total=0 failed_total=0 cat $OUTS # if awk exists, use it to print total statistics if which awk > /dev/null ; then awk '/total:/ { passed += $3; failed += $5; } END { printf " TOTAL: PASSED %3d FAILED %3d\n", passed, failed; }' $OUTS fi for out in $OUTS ; do if [ ! -s $out ] ; then echo " $out file empty (test crashed)!" else if grep -q WARNING $out ; then echo " $out produced warnings:" grep WARNING $out fi fi done qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tch1dn.f90000066400000000000000000000070671522610125300236040ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tch1dn integer n external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing Cholesky rank-1 downdate routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 write (*,*) 'sch1dn test:' call stest(n) write (*,*) 'dch1dn test:' call dtest(n) write (*,*) 'cch1dn test:' call ctest(n) write (*,*) 'zch1dn test:' call ztest(n) call pstats end program subroutine stest(n) use iso_fortran_env integer n real(real32) A(n,n),R(n,n),u(n),wrk(2*n) external srandg,scopy,schgen,sch1up,schchk,sch1dn integer info ! set up random matrix & vectors call srandg(n,n,A,n) call srandg(n,1,u,n) call scopy(n,u,1,wrk,1) ! generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) ! update the Cholesky decomposition call sch1up(n,R,n,u,wrk(1+n)) ! downdate it back call sch1dn(n,R,n,wrk,wrk(1+n),info) ! check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n) use iso_fortran_env integer n real(real64) A(n,n),R(n,n),u(n),wrk(2*n) external drandg,dcopy,dchgen,dch1up,dchchk,dch1dn integer info ! set up random matrix & vectors call drandg(n,n,A,n) call drandg(n,1,u,n) call dcopy(n,u,1,wrk,1) ! generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) ! update the Cholesky decomposition call dch1up(n,R,n,u,wrk(1+n)) ! downdate it back call dch1dn(n,R,n,wrk,wrk(1+n),info) ! check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n) use iso_fortran_env integer n complex(real32) A(n,n),R(n,n),u(n),wrk(n) real(real32) rwrk(n) external crandg,ccopy,cchgen,cch1up,cchchk,cch1dn integer info ! set up random matrix & vectors call crandg(n,n,A,n) call crandg(n,1,u,n) call ccopy(n,u,1,wrk,1) ! generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) ! update the Cholesky decomposition call cch1up(n,R,n,u,rwrk) ! downdate it back call cch1dn(n,R,n,wrk,rwrk,info) ! check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n) use iso_fortran_env integer n complex(real64) A(n,n),R(n,n),u(n),wrk(n) real(real64) rwrk(n) external zrandg,zcopy,zchgen,zch1up,zchchk,zch1dn integer info ! set up random matrix & vectors call zrandg(n,n,A,n) call zrandg(n,1,u,n) call zcopy(n,u,1,wrk,1) ! generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) ! update the Cholesky decomposition call zch1up(n,R,n,u,rwrk) ! downdate it back call zch1dn(n,R,n,wrk,rwrk,info) ! check result call zchchk(n,A,n,R,n) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tch1up.f90000066400000000000000000000064711522610125300236250ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tch1up integer n external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing Cholesky rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 write (*,*) 'sch1up test:' call stest(n) write (*,*) 'dch1up test:' call dtest(n) write (*,*) 'cch1up test:' call ctest(n) write (*,*) 'zch1up test:' call ztest(n) call pstats end program subroutine stest(n) use iso_fortran_env integer n real(real32) A(n,n),R(n,n),u(n),wrk(n) external srandg,schgen,ssyr,sch1up,schchk ! set up random matrix & vectors call srandg(n,n,A,n) call srandg(n,1,u,n) ! generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) ! update the matrix A call ssyr('U',n,1e0,u,1,A,n) ! update the Cholesky decomposition call sch1up(n,R,n,u,wrk) ! check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n) use iso_fortran_env integer n real(real64) A(n,n),R(n,n),u(n),wrk(n) external drandg,dchgen,dsyr,dch1up,dchchk ! set up random matrix & vectors call drandg(n,n,A,n) call drandg(n,1,u,n) ! generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) ! update the matrix A call dsyr('U',n,1d0,u,1,A,n) ! update the Cholesky decomposition call dch1up(n,R,n,u,wrk) ! check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n) use iso_fortran_env integer n complex(real32) A(n,n),R(n,n),u(n) real(real32) rwrk(n) external crandg,cchgen,cher,cch1up,cchchk ! set up random matrix & vectors call crandg(n,n,A,n) call crandg(n,1,u,n) ! generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) ! update the matrix A call cher('U',n,1e0,u,1,A,n) ! update the Cholesky decomposition call cch1up(n,R,n,u,rwrk) ! check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n) use iso_fortran_env integer n complex(real64) A(n,n),R(n,n),u(n) real(real64) rwrk(n) external zrandg,zchgen,zher,zch1up,zchchk ! set up random matrix & vectors call zrandg(n,n,A,n) call zrandg(n,1,u,n) ! generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) ! update the matrix A call zher('U',n,1d0,u,1,A,n) ! update the Cholesky decomposition call zch1up(n,R,n,u,rwrk) ! check result call zchchk(n,A,n,R,n) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tchdex.f90000066400000000000000000000074321522610125300236760ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tchdex integer n,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing Cholesky symmetric delete routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 j = 15 write (*,*) 'schdex test:' call stest(n,j) write (*,*) 'dchdex test:' call dtest(n,j) write (*,*) 'cchdex test:' call ctest(n,j) write (*,*) 'zchdex test:' call ztest(n,j) call pstats end program subroutine stest(n,j) use iso_fortran_env integer n,j real(real32) A(n,n),R(n,n),wrk(n) external srandg,schgen,schdex,schchk integer i,k ! set up random matrix & vectors call srandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) ! update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do ! update the Cholesky decomposition call schdex(n,R,n,j,wrk) ! check result call schchk(n-1,A,n,R,n) end subroutine subroutine dtest(n,j) use iso_fortran_env integer n,j real(real64) A(n,n),R(n,n),wrk(n) external drandg,dchgen,dchdex,dchchk integer i,k ! set up random matrix & vectors call drandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) ! update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do ! update the Cholesky decomposition call dchdex(n,R,n,j,wrk) ! check result call dchchk(n-1,A,n,R,n) end subroutine subroutine ctest(n,j) use iso_fortran_env integer n,j complex(real32) A(n,n),R(n,n) real(real32) rwrk(n) external crandg,cchgen,cchdex,cchchk integer i,k ! set up random matrix & vectors call crandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) ! update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do ! update the Cholesky decomposition call cchdex(n,R,n,j,rwrk) ! check result call cchchk(n-1,A,n,R,n) end subroutine subroutine ztest(n,j) use iso_fortran_env integer n,j complex(real64) A(n,n),R(n,n) real(real64) rwrk(n) external zrandg,zchgen,zchdex,zchchk integer i,k ! set up random matrix & vectors call zrandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) ! update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do ! update the Cholesky decomposition call zchdex(n,R,n,j,rwrk) ! check result call zchchk(n-1,A,n,R,n) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tchinx.f90000066400000000000000000000075661522610125300237240ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tchinx integer n,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing Cholesky symmetric insert routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 j = 25 write (*,*) 'schinx test:' call stest(n,j) write (*,*) 'dchinx test:' call dtest(n,j) write (*,*) 'cchinx test:' call ctest(n,j) write (*,*) 'zchinx test:' call ztest(n,j) call pstats end program subroutine stest(n,j) use iso_fortran_env integer n,j real(real32) A(n,n),R(n,n),u(n),wrk(n) external srandg,schgen,schinx,schchk,schdex integer info,i ! set up random matrix & vectors call srandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) ! save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = A(j,i) end do ! update the Cholesky decomposition call schdex(n,R,n,j,wrk) ! put the row/column back call schinx(n-1,R,n,j,u,wrk,info) ! check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n,j) use iso_fortran_env integer n,j real(real64) A(n,n),R(n,n),u(n),wrk(n) external drandg,dchgen,dchinx,dchchk,dchdex integer info,i ! set up random matrix & vectors call drandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) ! save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = A(j,i) end do ! update the Cholesky decomposition call dchdex(n,R,n,j,wrk) ! put the row/column back call dchinx(n-1,R,n,j,u,wrk,info) ! check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n,j) use iso_fortran_env integer n,j complex(real32) A(n,n),R(n,n),u(n) real(real32) rwrk(n) external crandg,cchgen,cchinx,cchchk,cchdex integer info,i ! set up random matrix & vectors call crandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) ! save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = conjg(A(j,i)) end do ! update the Cholesky decomposition call cchdex(n,R,n,j,rwrk) ! put the row/column back call cchinx(n-1,R,n,j,u,rwrk,info) ! check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n,j) use iso_fortran_env integer n,j complex(real64) A(n,n),R(n,n),u(n) real(real64) rwrk(n) external zrandg,zchgen,zchinx,zchchk,zchdex integer info,i ! set up random matrix & vectors call zrandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) ! save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = conjg(A(j,i)) end do ! update the Cholesky decomposition call zchdex(n,R,n,j,rwrk) ! put the row/column back call zchinx(n-1,R,n,j,u,rwrk,info) ! check result call zchchk(n,A,n,R,n) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tchshx.f90000066400000000000000000000075141522610125300237210ustar00rootroot00000000000000program tchshx integer n,i,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR column shift routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 i = 20 j = 40 write (*,*) 'schshx test (left shift):' call stest(n,i,j) write (*,*) 'dchshx test (left shift):' call dtest(n,i,j) write (*,*) 'cchshx test (left shift):' call ctest(n,i,j) write (*,*) 'zchshx test (left shift):' call ztest(n,i,j) i = 40 j = 20 write (*,*) 'schshx test (right shift):' call stest(n,i,j) write (*,*) 'dchshx test (right shift):' call dtest(n,i,j) write (*,*) 'cchshx test (right shift):' call ctest(n,i,j) write (*,*) 'zchshx test (right shift):' call ztest(n,i,j) call pstats end program subroutine stest(n,i,j) use iso_fortran_env integer n,i,j real(real32) A(n,n),R(n,n),wrk(2*n) external srandg,schgen,sswap,schshx,schchk integer k ! set up random matrix call srandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) ! update matrix if (i < j) then do k = i,j-1 call sswap(n,A(1,k),1,A(1,k+1),1) call sswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call sswap(n,A(1,k),1,A(1,k-1),1) call sswap(n,A(k,1),n,A(k-1,1),n) end do end if ! update factorization call schshx(n,R,n,i,j,wrk) ! check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n,i,j) use iso_fortran_env integer n,i,j real(real64) A(n,n),R(n,n),wrk(2*n) external drandg,dchgen,dswap,dchshx,dchchk integer k ! set up random matrix call drandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) ! update matrix if (i < j) then do k = i,j-1 call dswap(n,A(1,k),1,A(1,k+1),1) call dswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call dswap(n,A(1,k),1,A(1,k-1),1) call dswap(n,A(k,1),n,A(k-1,1),n) end do end if ! update factorization call dchshx(n,R,n,i,j,wrk) ! check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n,i,j) use iso_fortran_env integer n,i,j complex(real32) A(n,n),R(n,n),wrk(n) real(real32) rwrk(n) external crandg,cchgen,cswap,cchshx,cchchk integer k ! set up random matrix call crandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) ! update matrix if (i < j) then do k = i,j-1 call cswap(n,A(1,k),1,A(1,k+1),1) call cswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call cswap(n,A(1,k),1,A(1,k-1),1) call cswap(n,A(k,1),n,A(k-1,1),n) end do end if ! update factorization call cchshx(n,R,n,i,j,wrk,rwrk) ! check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n,i,j) use iso_fortran_env integer n,i,j complex(real64) A(n,n),R(n,n),wrk(n) real(real64) rwrk(n) external zrandg,zchgen,zswap,zchshx,zchchk integer k ! set up random matrix call zrandg(n,n,A,n) ! generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) ! update matrix if (i < j) then do k = i,j-1 call zswap(n,A(1,k),1,A(1,k+1),1) call zswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call zswap(n,A(1,k),1,A(1,k-1),1) call zswap(n,A(k,1),n,A(k-1,1),n) end do end if ! update factorization call zchshx(n,R,n,i,j,wrk,rwrk) ! check result call zchchk(n,A,n,R,n) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/test_qrupdate_error.f90000066400000000000000000000102221522610125300265030ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! module test_aux implicit none type :: aux_data character(len=32) :: message integer :: val end type aux_data end module test_aux program test_qrupdate_error use iso_fortran_env use qrupdate_error use test_state use test_aux implicit none type(aux_data), target :: my_data class(*), pointer :: p_aux_data procedure(error_handler_if), pointer :: p_handler print *, 'Running qrupdate_error tests...' ! Test 1: Default behavior (no custom handler) call reset() call qrupdate_xerror('TEST_ROUTINE', 42) if (.not. xerbla_called) then print *, 'Test 1 Failed: xerbla was not called' stop end if print *, 'Test 1 Passed: Default behavior calls xerbla' ! Test 2: Custom handler without auxiliary data call reset() p_handler => my_custom_handler call qrupdate_set_error(p_handler) call qrupdate_xerror('CUSTOM_ROUTINE', 123) if (.not. custom_handler_called) then print *, 'Test 2 Failed: Custom handler was not called' stop end if if (last_srname /= 'CUSTOM_ROUTINE' .or. last_info /= 123) then print *, 'Test 2 Failed: Incorrect arguments passed to handler' stop end if print *, 'Test 2 Passed: Custom handler called correctly' ! Test 3: Custom handler with auxiliary data call reset() my_data%message = 'Hello World' my_data%val = 999 p_aux_data => my_data call qrupdate_set_error_data(p_aux_data) call qrupdate_xerror('DATA_ROUTINE', 7) if (.not. custom_handler_called) then print *, 'Test 3 Failed: Custom handler was not called' stop end if print *, 'Test 3 Passed: Custom handler called with auxiliary data' ! Test 4: Overwriting handler call reset() p_handler => my_other_handler call qrupdate_set_error(p_handler) call qrupdate_xerror('OTHER_ROUTINE', 1) if (call_count /= 1) then print *, 'Test 4 Failed: Incorrect call count for other handler' stop end if print *, 'Test 4 Passed: Handler overwritten successfully' print *, 'All qrupdate_error tests passed!' contains subroutine my_custom_handler(srname, info, aux) use test_state character(len=*), intent(in) :: srname integer, intent(in) :: info class(*), optional, intent(in) :: aux if (present(aux)) then call_count = call_count endif print *, 'my_custom_handler called from ', srname, ' with ', info custom_handler_called = .true. last_srname = srname last_info = info call_count = call_count + 1 end subroutine my_custom_handler subroutine my_other_handler(srname, info, aux) use test_state character(len=*), intent(in) :: srname integer, intent(in) :: info class(*), optional, intent(in) :: aux if (present(aux)) then call_count = call_count endif print *, 'my_other_handler called from ', srname, ' with ', info custom_handler_called = .true. call_count = call_count + 1 end subroutine my_other_handler end program test_qrupdate_error subroutine xerbla(srname, info) use test_state implicit none character(len=*), intent(in) :: srname integer, intent(in) :: info xerbla_called = .true. print *, 'Mock xerbla called from: ', srname, ' with info: ', info end subroutine xerbla qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/test_qrupdate_validation.f90000066400000000000000000000706041522610125300275160ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! !> \brief Tests input validation (qrupdate_xerror) for all qrupdate functions. program test_qrupdate_validation use iso_fortran_env use qrupdate_error use test_state implicit none integer, parameter :: n = 5 external sch1dn, dch1dn, cch1dn, zch1dn external schdex, dchdex, cchdex, zchdex external schinx, dchinx, cchinx, zchinx external schshx, dchshx, cchshx, zchshx external slu1up, dlu1up, clu1up, zlu1up external slup1up, dlup1up, clup1up, zlup1up external sqr1up, dqr1up, cqr1up, zqr1up external sqrdec, dqrdec, cqrdec, zqrdec external sqrder, dqrder, cqrder, zqrder external sqrinc, dqrinc, cqrinc, zqrinc external sqrinr, dqrinr, cqrinr, zqrinr external sqrshc, dqrshc, cqrshc, zqrshc external sqrot, dqrot, cqrot, zqrot external sqhqr, dqhqr, cqhqr, zqhqr external sqrqh, dqrqh, cqrqh, zqrqh external sgqvec, dgqvec, cgqvec, zgqvec integer :: info real(real32) :: R_s(n,n), u_s(n), w_s(n), rw_s(n) real(real64) :: R_d(n,n), u_d(n), w_d(n), rw_d(n) complex(real32) :: R_c(n,n), u_c(n), rw_c(n) complex(real32) :: R_z(n,n), u_z(n), rw_z(n) real(real32) :: Q_s(n,n), c_s(n-1), s_s(n-1), rhs_s(n) real(real64) :: Q_d(n,n), c_d(n-1), s_d(n-1), rhs_d(n) complex(real32) :: Q_c(n,n), Q_z(n,n), rhs_c(n), rhs_z(n) real(real32) :: c_c(n-1), c_z(n-1) complex(real32) :: s_c(n-1), s_z(n-1) real(real32) :: L_s(n,n), v_s(n), wv_s(n) real(real64) :: L_d(n,n), v_d(n), wv_d(n) complex(real32) :: L_c(n,n), v_c(n), wv_c(n), L_z(n,n), v_z(n), wv_z(n) real(real32) :: p_s(n), p2_s(n) real(real64) :: p_d(n), p2_d(n) complex(real32) :: p_c(n), p2_c(n), p_z(n), p2_z(n) real(real32) :: x_s(n), x_d(n), x_c(n), x_z(n) character(len=1) :: dir procedure(error_handler_if), pointer :: p_handler print *, 'Testing input validation for all qrupdate functions...' ! Initialize arrays to avoid undefined values R_s = 0; u_s = 0; w_s = 0; rw_s = 0 R_d = 0; u_d = 0; w_d = 0; rw_d = 0 R_c = 0; u_c = 0; rw_c = 0 R_z = 0; u_z = 0; rw_z = 0 Q_s = 0; c_s = 0; s_s = 0; rhs_s = 0 Q_d = 0; c_d = 0; s_d = 0; rhs_d = 0 Q_c = 0; c_c = 0; s_c = 0; rhs_c = 0 Q_z = 0; c_z = 0; s_z = 0; rhs_z = 0 L_s = 0; v_s = 0; wv_s = 0 L_d = 0; v_d = 0; wv_d = 0 L_c = 0; v_c = 0; wv_c = 0 L_z = 0; v_z = 0; wv_z = 0 p_s = 0; p2_s = 0; p_d = 0; p2_d = 0 p_c = 0; p2_c = 0; p_z = 0; p2_z = 0 x_s = 0; x_d = 0; x_c = 0; x_z = 0 p_handler => pxerbla call qrupdate_set_error(p_handler) ! ====== Cholesky downdate ====== ! sch1dn(n,R,ldr,u,w,info): validates n>=0, ldr>=n (negates info before xerror) call reset() call sch1dn(-1, R_s, n, u_s, w_s, info) call check_error('SCH1DN', 1) call reset() call sch1dn(n, R_s, n-1, u_s, w_s, info) call check_error('SCH1DN', 3) call reset() call dch1dn(-1, R_d, n, u_d, w_d, info) call check_error('DCH1DN', 1) call reset() call dch1dn(n, R_d, n-1, u_d, w_d, info) call check_error('DCH1DN', 3) call reset() call cch1dn(-1, R_c, n, u_c, rw_c, info) call check_error('CCH1DN', 1) call reset() call cch1dn(n, R_c, n-1, u_c, rw_c, info) call check_error('CCH1DN', 3) call reset() call zch1dn(-1, R_z, n, u_z, rw_z, info) call check_error('ZCH1DN', 1) call reset() call zch1dn(n, R_z, n-1, u_z, rw_z, info) call check_error('ZCH1DN', 3) ! ====== Cholesky delete ====== ! schdex(n,R,ldr,j,w): validates n>=0, j in [1,n] call reset() call schdex(-1, R_s, n, 1, w_s) call check_error('SCHDEX', 1) call reset() call schdex(n, R_s, n, 0, w_s) call check_error('SCHDEX', 4) call reset() call dchdex(-1, R_d, n, 1, w_d) call check_error('DCHDEX', 1) call reset() call dchdex(n, R_d, n, 0, w_d) call check_error('DCHDEX', 4) call reset() call cchdex(-1, R_c, n, 1, rw_c) call check_error('CCHDEX', 1) call reset() call cchdex(n, R_c, n, 0, rw_c) call check_error('CCHDEX', 4) call reset() call zchdex(-1, R_z, n, 1, rw_z) call check_error('ZCHDEX', 1) call reset() call zchdex(n, R_z, n, 0, rw_z) call check_error('ZCHDEX', 4) ! ====== Cholesky insert ====== ! schinx(n,R,ldr,j,u,w,info): validates n>=0, j in [1,n+1] (passes info directly) ! dchinx uses -info before xerror, others pass info directly call reset() call schinx(-1, R_s, n, 1, u_s, w_s, info) call check_error('SCHINX', -1) call reset() call schinx(n, R_s, n, 0, u_s, w_s, info) call check_error('SCHINX', -4) call reset() call dchinx(-1, R_d, n, 1, u_d, w_d, info) call check_error('DCHINX', 1) call reset() call dchinx(n, R_d, n, 0, u_d, w_d, info) call check_error('DCHINX', 4) call reset() call cchinx(-1, R_c, n, 1, u_c, rw_c, info) call check_error('CCHINX', -1) call reset() call cchinx(n, R_c, n, 0, u_c, rw_c, info) call check_error('CCHINX', -4) call reset() call zchinx(-1, R_z, n, 1, u_z, rw_z, info) call check_error('ZCHINX', -1) call reset() call zchinx(n, R_z, n, 0, u_z, rw_z, info) call check_error('ZCHINX', -4) ! ====== Cholesky shift ====== ! schshx(n,R,ldr,i,j,w): validates n>=0, i in [1,n], j in [1,n] call reset() call schshx(-1, R_s, n, 1, 1, w_s) call check_error('SCHSHX', 1) call reset() call schshx(n, R_s, n, 0, 1, w_s) call check_error('SCHSHX', 4) call reset() call schshx(n, R_s, n, 1, 0, w_s) call check_error('SCHSHX', 5) call reset() call dchshx(-1, R_d, n, 1, 1, w_d) call check_error('DCHSHX', 1) call reset() call dchshx(n, R_d, n, 0, 1, w_d) call check_error('DCHSHX', 4) call reset() call dchshx(n, R_d, n, 1, 0, w_d) call check_error('DCHSHX', 5) call reset() call cchshx(-1, R_c, n, 1, 1, rw_s, rw_c) call check_error('CCHSHX', 1) call reset() call cchshx(n, R_c, n, 0, 1, rw_s, rw_c) call check_error('CCHSHX', 4) call reset() call cchshx(n, R_c, n, 1, 0, rw_s, rw_c) call check_error('CCHSHX', 5) call reset() call zchshx(-1, R_z, n, 1, 1, rw_d, rw_z) call check_error('ZCHSHX', 1) call reset() call zchshx(n, R_z, n, 0, 1, rw_d, rw_z) call check_error('ZCHSHX', 4) call reset() call zchshx(n, R_z, n, 1, 0, rw_d, rw_z) call check_error('ZCHSHX', 5) ! ====== LU rank-1 update ====== ! slu1up(m,n,L,ldl,R,ldr,u,v): validates m>=0, n>=0, ldl>=m, ldr>=min(m,n) call reset() call slu1up(-1, n, L_s, n, R_s, n, rhs_s, v_s) call check_error('SLU1UP', 1) call reset() call slu1up(n, -1, L_s, n, R_s, n, rhs_s, v_s) call check_error('SLU1UP', 2) call reset() call slu1up(n, n, L_s, n-1, R_s, n, rhs_s, v_s) call check_error('SLU1UP', 4) call reset() call slu1up(n, n, L_s, n, R_s, n-1, rhs_s, v_s) call check_error('SLU1UP', 6) call reset() call dlu1up(-1, n, L_d, n, R_d, n, rhs_d, v_d) call check_error('DLU1UP', 1) call reset() call dlu1up(n, -1, L_d, n, R_d, n, rhs_d, v_d) call check_error('DLU1UP', 2) call reset() call dlu1up(n, n, L_d, n-1, R_d, n, rhs_d, v_d) call check_error('DLU1UP', 4) call reset() call dlu1up(n, n, L_d, n, R_d, n-1, rhs_d, v_d) call check_error('DLU1UP', 6) call reset() call clu1up(-1, n, L_c, n, R_c, n, rhs_c, v_c) call check_error('CLU1UP', 1) call reset() call clu1up(n, -1, L_c, n, R_c, n, rhs_c, v_c) call check_error('CLU1UP', 2) call reset() call clu1up(n, n, L_c, n-1, R_c, n, rhs_c, v_c) call check_error('CLU1UP', 4) call reset() call clu1up(n, n, L_c, n, R_c, n-1, rhs_c, v_c) call check_error('CLU1UP', 6) call reset() call zlu1up(-1, n, L_z, n, R_z, n, rhs_z, v_z) call check_error('ZLU1UP', 1) call reset() call zlu1up(n, -1, L_z, n, R_z, n, rhs_z, v_z) call check_error('ZLU1UP', 2) call reset() call zlu1up(n, n, L_z, n-1, R_z, n, rhs_z, v_z) call check_error('ZLU1UP', 4) call reset() call zlu1up(n, n, L_z, n, R_z, n-1, rhs_z, v_z) call check_error('ZLU1UP', 6) ! ====== LU+perm rank-1 update ====== ! slup1up(m,n,L,ldl,R,ldr,p,u,v,w): validates m>=0, n>=0, ldl>=m, ldr>=min(m,n) call reset() call slup1up(-1, n, L_s, n, R_s, n, p_s, rhs_s, v_s, wv_s) call check_error('SLUP1UP', 1) call reset() call slup1up(n, -1, L_s, n, R_s, n, p_s, rhs_s, v_s, wv_s) call check_error('SLUP1UP', 2) call reset() call slup1up(n, n, L_s, n-1, R_s, n, p_s, rhs_s, v_s, wv_s) call check_error('SLUP1UP', 4) call reset() call slup1up(n, n, L_s, n, R_s, n-1, p_s, rhs_s, v_s, wv_s) call check_error('SLUP1UP', 6) call reset() call dlup1up(-1, n, L_d, n, R_d, n, p_d, rhs_d, v_d, wv_d) call check_error('DLUP1UP', 1) call reset() call dlup1up(n, -1, L_d, n, R_d, n, p_d, rhs_d, v_d, wv_d) call check_error('DLUP1UP', 2) call reset() call dlup1up(n, n, L_d, n-1, R_d, n, p_d, rhs_d, v_d, wv_d) call check_error('DLUP1UP', 4) call reset() call dlup1up(n, n, L_d, n, R_d, n-1, p_d, rhs_d, v_d, wv_d) call check_error('DLUP1UP', 6) call reset() call clup1up(-1, n, L_c, n, R_c, n, p_c, rhs_c, v_c, wv_s) call check_error('CLUP1UP', 1) call reset() call clup1up(n, -1, L_c, n, R_c, n, p_c, rhs_c, v_c, wv_s) call check_error('CLUP1UP', 2) call reset() call clup1up(n, n, L_c, n-1, R_c, n, p_c, rhs_c, v_c, wv_s) call check_error('CLUP1UP', 4) call reset() call clup1up(n, n, L_c, n, R_c, n-1, p_c, rhs_c, v_c, wv_s) call check_error('CLUP1UP', 6) call reset() call zlup1up(-1, n, L_z, n, R_z, n, p_z, rhs_z, v_z, wv_d) call check_error('ZLUP1UP', 1) call reset() call zlup1up(n, -1, L_z, n, R_z, n, p_z, rhs_z, v_z, wv_d) call check_error('ZLUP1UP', 2) call reset() call zlup1up(n, n, L_z, n-1, R_z, n, p_z, rhs_z, v_z, wv_d) call check_error('ZLUP1UP', 4) call reset() call zlup1up(n, n, L_z, n, R_z, n-1, p_z, rhs_z, v_z, wv_d) call check_error('ZLUP1UP', 6) ! ====== QR rank-1 update ====== ! sqr1up(m,n,k,Q,ldq,R,ldr,u,v,w): validates m>=0, n>=0, k valid, ldq>=m, ldr>=k call reset() call sqr1up(-1, n, n, Q_s, n, R_s, n, rhs_s, v_s, wv_s) call check_error('SQR1UP', 1) call reset() call sqr1up(n, -1, n, Q_s, n, R_s, n, rhs_s, v_s, wv_s) call check_error('SQR1UP', 2) call reset() call sqr1up(n, n, 99, Q_s, n, R_s, n, rhs_s, v_s, wv_s) call check_error('SQR1UP', 3) call reset() call sqr1up(n, n, n, Q_s, n-1, R_s, n, rhs_s, v_s, wv_s) call check_error('SQR1UP', 5) call reset() call sqr1up(n, n, n, Q_s, n, R_s, n-1, rhs_s, v_s, wv_s) call check_error('SQR1UP', 7) call reset() call dqr1up(-1, n, n, Q_d, n, R_d, n, rhs_d, v_d, wv_d) call check_error('DQR1UP', 1) call reset() call dqr1up(n, -1, n, Q_d, n, R_d, n, rhs_d, v_d, wv_d) call check_error('DQR1UP', 2) call reset() call dqr1up(n, n, 99, Q_d, n, R_d, n, rhs_d, v_d, wv_d) call check_error('DQR1UP', 3) call reset() call dqr1up(n, n, n, Q_d, n-1, R_d, n, rhs_d, v_d, wv_d) call check_error('DQR1UP', 5) call reset() call dqr1up(n, n, n, Q_d, n, R_d, n-1, rhs_d, v_d, wv_d) call check_error('DQR1UP', 7) call reset() call cqr1up(-1, n, n, Q_c, n, R_c, n, rhs_c, v_c, wv_s) call check_error('CQR1UP', 1) call reset() call cqr1up(n, -1, n, Q_c, n, R_c, n, rhs_c, v_c, wv_s) call check_error('CQR1UP', 2) call reset() call cqr1up(n, n, 99, Q_c, n, R_c, n, rhs_c, v_c, wv_s) call check_error('CQR1UP', 3) call reset() call cqr1up(n, n, n, Q_c, n-1, R_c, n, rhs_c, v_c, wv_s) call check_error('CQR1UP', 5) call reset() call cqr1up(n, n, n, Q_c, n, R_c, n-1, rhs_c, v_c, wv_s) call check_error('CQR1UP', 7) call reset() call zqr1up(-1, n, n, Q_z, n, R_z, n, rhs_z, v_z, wv_d) call check_error('ZQR1UP', 1) call reset() call zqr1up(n, -1, n, Q_z, n, R_z, n, rhs_z, v_z, wv_d) call check_error('ZQR1UP', 2) call reset() call zqr1up(n, n, 99, Q_z, n, R_z, n, rhs_z, v_z, wv_d) call check_error('ZQR1UP', 3) call reset() call zqr1up(n, n, n, Q_z, n-1, R_z, n, rhs_z, v_z, wv_d) call check_error('ZQR1UP', 5) call reset() call zqr1up(n, n, n, Q_z, n, R_z, n-1, rhs_z, v_z, wv_d) call check_error('ZQR1UP', 7) ! ====== QR delete (column) ====== ! sqrdec(m,n,k,Q,ldq,R,ldr,j,w): validates m>=0, n>=0, k valid, ldq>=m, ldr>=k, j in [1,n+1] call reset() call sqrdec(-1, n, n, Q_s, n, R_s, n, 1, w_s) call check_error('SQRDEC', 1) call reset() call sqrdec(n, -1, n, Q_s, n, R_s, n, 1, w_s) call check_error('SQRDEC', 2) call reset() call sqrdec(n, n, 99, Q_s, n, R_s, n, 1, w_s) call check_error('SQRDEC', 3) call reset() call sqrdec(n, n, n, Q_s, n-1, R_s, n, 1, w_s) call check_error('SQRDEC', 5) call reset() call sqrdec(n, n, n, Q_s, n, R_s, n-1, 1, w_s) call check_error('SQRDEC', 7) call reset() call sqrdec(n, n, n, Q_s, n, R_s, n, 0, w_s) call check_error('SQRDEC', 8) call reset() call dqrdec(-1, n, n, Q_d, n, R_d, n, 1, w_d) call check_error('DQRDEC', 1) call reset() call dqrdec(n, -1, n, Q_d, n, R_d, n, 1, w_d) call check_error('DQRDEC', 2) call reset() call dqrdec(n, n, 99, Q_d, n, R_d, n, 1, w_d) call check_error('DQRDEC', 3) call reset() call dqrdec(n, n, n, Q_d, n-1, R_d, n, 1, w_d) call check_error('DQRDEC', 5) call reset() call dqrdec(n, n, n, Q_d, n, R_d, n-1, 1, w_d) call check_error('DQRDEC', 7) call reset() call dqrdec(n, n, n, Q_d, n, R_d, n, 0, w_d) call check_error('DQRDEC', 8) call reset() call cqrdec(-1, n, n, Q_c, n, R_c, n, 1, rw_c) call check_error('CQRDEC', 1) call reset() call cqrdec(n, -1, n, Q_c, n, R_c, n, 1, rw_c) call check_error('CQRDEC', 2) call reset() call cqrdec(n, n, 99, Q_c, n, R_c, n, 1, rw_c) call check_error('CQRDEC', 3) call reset() call cqrdec(n, n, n, Q_c, n-1, R_c, n, 1, rw_c) call check_error('CQRDEC', 5) call reset() call cqrdec(n, n, n, Q_c, n, R_c, n-1, 1, rw_c) call check_error('CQRDEC', 7) call reset() call cqrdec(n, n, n, Q_c, n, R_c, n, 0, rw_c) call check_error('CQRDEC', 8) call reset() call zqrdec(-1, n, n, Q_z, n, R_z, n, 1, rw_z) call check_error('ZQRDEC', 1) call reset() call zqrdec(n, -1, n, Q_z, n, R_z, n, 1, rw_z) call check_error('ZQRDEC', 2) call reset() call zqrdec(n, n, 99, Q_z, n, R_z, n, 1, rw_z) call check_error('ZQRDEC', 3) call reset() call zqrdec(n, n, n, Q_z, n-1, R_z, n, 1, rw_z) call check_error('ZQRDEC', 5) call reset() call zqrdec(n, n, n, Q_z, n, R_z, n-1, 1, rw_z) call check_error('ZQRDEC', 7) call reset() call zqrdec(n, n, n, Q_z, n, R_z, n, 0, rw_z) call check_error('ZQRDEC', 8) ! ====== QR delete (row) ====== ! sqrder(m,n,Q,ldq,R,ldr,j,w): validates m>=1, j in [1,m] call reset() call sqrder(0, n, Q_s, n, R_s, n, 1, w_s) call check_error('SQRDER', 1) call reset() call sqrder(n, n, Q_s, n, R_s, n, 0, w_s) call check_error('SQRDER', 7) call reset() call dqrder(0, n, Q_d, n, R_d, n, 1, w_d) call check_error('DQRDER', 1) call reset() call dqrder(n, n, Q_d, n, R_d, n, 0, w_d) call check_error('DQRDER', 7) call reset() call cqrder(0, n, Q_c, n, R_c, n, 1, rw_c) call check_error('CQRDER', 1) call reset() call cqrder(n, n, Q_c, n, R_c, n, 0, rw_c) call check_error('CQRDER', 7) call reset() call zqrder(0, n, Q_z, n, R_z, n, 1, rw_z) call check_error('ZQRDER', 1) call reset() call zqrder(n, n, Q_z, n, R_z, n, 0, rw_z) call check_error('ZQRDER', 7) ! ====== QR increment (column) ====== ! sqrinc(m,n,k,Q,ldq,R,ldr,j,x,w): validates m>=0, n>=0, k valid, ldq>=m, ldr>=min(m,k+1), j in [1,n+1] call reset() call sqrinc(-1, n, n, Q_s, n, R_s, n, 1, x_s, w_s) call check_error('SQRINC', 1) call reset() call sqrinc(n, -1, n, Q_s, n, R_s, n, 1, x_s, w_s) call check_error('SQRINC', 2) call reset() call sqrinc(n, n, 99, Q_s, n, R_s, n, 1, x_s, w_s) call check_error('SQRINC', 3) call reset() call sqrinc(n, n, n, Q_s, n-1, R_s, n, 1, x_s, w_s) call check_error('SQRINC', 5) call reset() call sqrinc(n, n, n, Q_s, n, R_s, 0, 1, x_s, w_s) call check_error('SQRINC', 7) call reset() call sqrinc(n, n, n, Q_s, n, R_s, n, 0, x_s, w_s) call check_error('SQRINC', 8) call reset() call dqrinc(-1, n, n, Q_d, n, R_d, n, 1, x_d, w_d) call check_error('DQRINC', 1) call reset() call dqrinc(n, -1, n, Q_d, n, R_d, n, 1, x_d, w_d) call check_error('DQRINC', 2) call reset() call dqrinc(n, n, 99, Q_d, n, R_d, n, 1, x_d, w_d) call check_error('DQRINC', 3) call reset() call dqrinc(n, n, n, Q_d, n-1, R_d, n, 1, x_d, w_d) call check_error('DQRINC', 5) call reset() call dqrinc(n, n, n, Q_d, n, R_d, 0, 1, x_d, w_d) call check_error('DQRINC', 7) call reset() call dqrinc(n, n, n, Q_d, n, R_d, n, 0, x_d, w_d) call check_error('DQRINC', 8) call reset() call cqrinc(-1, n, n, Q_c, n, R_c, n, 1, x_c, rw_c) call check_error('CQRINC', 1) call reset() call cqrinc(n, -1, n, Q_c, n, R_c, n, 1, x_c, rw_c) call check_error('CQRINC', 2) call reset() call cqrinc(n, n, 99, Q_c, n, R_c, n, 1, x_c, rw_c) call check_error('CQRINC', 3) call reset() call cqrinc(n, n, n, Q_c, n-1, R_c, n, 1, x_c, rw_c) call check_error('CQRINC', 5) call reset() call cqrinc(n, n, n, Q_c, n, R_c, 0, 1, x_c, rw_c) call check_error('CQRINC', 7) call reset() call cqrinc(n, n, n, Q_c, n, R_c, n, 0, x_c, rw_c) call check_error('CQRINC', 8) call reset() call zqrinc(-1, n, n, Q_z, n, R_z, n, 1, x_z, rw_z) call check_error('ZQRINC', 1) call reset() call zqrinc(n, -1, n, Q_z, n, R_z, n, 1, x_z, rw_z) call check_error('ZQRINC', 2) call reset() call zqrinc(n, n, 99, Q_z, n, R_z, n, 1, x_z, rw_z) call check_error('ZQRINC', 3) call reset() call zqrinc(n, n, n, Q_z, n-1, R_z, n, 1, x_z, rw_z) call check_error('ZQRINC', 5) call reset() call zqrinc(n, n, n, Q_z, n, R_z, 0, 1, x_z, rw_z) call check_error('ZQRINC', 7) call reset() call zqrinc(n, n, n, Q_z, n, R_z, n, 0, x_z, rw_z) call check_error('ZQRINC', 8) ! ====== QR inner (row) ====== ! sqrinr(m,n,Q,ldq,R,ldr,j,x,w): validates n>=0, j in [1,m+1] call reset() call sqrinr(n, -1, Q_s, n, R_s, n, 1, x_s, w_s) call check_error('SQRINR', 2) call reset() call sqrinr(n, n, Q_s, n, R_s, n, 0, x_s, w_s) call check_error('SQRINR', 7) call reset() call dqrinr(n, -1, Q_d, n, R_d, n, 1, x_d, w_d) call check_error('DQRINR', 2) call reset() call dqrinr(n, n, Q_d, n, R_d, n, 0, x_d, w_d) call check_error('DQRINR', 7) call reset() call cqrinr(n, -1, Q_c, n, R_c, n, 1, x_c, rw_c) call check_error('CQRINR', 2) call reset() call cqrinr(n, n, Q_c, n, R_c, n, 0, x_c, rw_c) call check_error('CQRINR', 7) call reset() call zqrinr(n, -1, Q_z, n, R_z, n, 1, x_z, rw_z) call check_error('ZQRINR', 2) call reset() call zqrinr(n, n, Q_z, n, R_z, n, 0, x_z, rw_z) call check_error('ZQRINR', 7) ! ====== QR shift ====== ! sqrshc(m,n,k,Q,ldq,R,ldr,i,j,w): validates m>=0, n>=0, k valid, i in [1,n], j in [1,n] call reset() call sqrshc(-1, n, n, Q_s, n, R_s, n, 1, 1, w_s) call check_error('SQRSHC', 1) call reset() call sqrshc(n, -1, n, Q_s, n, R_s, n, 1, 1, w_s) call check_error('SQRSHC', 2) call reset() call sqrshc(n, n, 99, Q_s, n, R_s, n, 1, 1, w_s) call check_error('SQRSHC', 3) call reset() call sqrshc(n, n, n, Q_s, n, R_s, n, 0, 1, w_s) call check_error('SQRSHC', 6) call reset() call sqrshc(n, n, n, Q_s, n, R_s, n, 1, 0, w_s) call check_error('SQRSHC', 7) call reset() call dqrshc(-1, n, n, Q_d, n, R_d, n, 1, 1, w_d) call check_error('DQRSHC', 1) call reset() call dqrshc(n, -1, n, Q_d, n, R_d, n, 1, 1, w_d) call check_error('DQRSHC', 2) call reset() call dqrshc(n, n, 99, Q_d, n, R_d, n, 1, 1, w_d) call check_error('DQRSHC', 3) call reset() call dqrshc(n, n, n, Q_d, n, R_d, n, 0, 1, w_d) call check_error('DQRSHC', 6) call reset() call dqrshc(n, n, n, Q_d, n, R_d, n, 1, 0, w_d) call check_error('DQRSHC', 7) call reset() call cqrshc(-1, n, n, Q_c, n, R_c, n, 1, 1, rw_s) call check_error('CQRSHC', 1) call reset() call cqrshc(n, -1, n, Q_c, n, R_c, n, 1, 1, rw_s) call check_error('CQRSHC', 2) call reset() call cqrshc(n, n, 99, Q_c, n, R_c, n, 1, 1, rw_s) call check_error('CQRSHC', 3) call reset() call cqrshc(n, n, n, Q_c, n, R_c, n, 0, 1, rw_s) call check_error('CQRSHC', 6) call reset() call cqrshc(n, n, n, Q_c, n, R_c, n, 1, 0, rw_s) call check_error('CQRSHC', 7) call reset() call zqrshc(-1, n, n, Q_z, n, R_z, n, 1, 1, rw_d) call check_error('ZQRSHC', 1) call reset() call zqrshc(n, -1, n, Q_z, n, R_z, n, 1, 1, rw_d) call check_error('ZQRSHC', 2) call reset() call zqrshc(n, n, 99, Q_z, n, R_z, n, 1, 1, rw_d) call check_error('ZQRSHC', 3) call reset() call zqrshc(n, n, n, Q_z, n, R_z, n, 0, 1, rw_d) call check_error('ZQRSHC', 6) call reset() call zqrshc(n, n, n, Q_z, n, R_z, n, 1, 0, rw_d) call check_error('ZQRSHC', 7) ! ====== Givens rotations ====== ! sqrot(dir,m,n,Q,ldq,c,s): validates dir in {F,B}, m>=0, n>=0, ldq>=m call reset() dir = 'X' call sqrot(dir, n, n, Q_s, n, c_s, s_s) call check_error('SQROT', 1) call reset() dir = 'F' call sqrot(dir, -1, n, Q_s, n, c_s, s_s) call check_error('SQROT', 2) call reset() call sqrot(dir, n, -1, Q_s, n, c_s, s_s) call check_error('SQROT', 3) call reset() call sqrot(dir, n, n, Q_s, n-1, c_s, s_s) call check_error('SQROT', 5) call reset() dir = 'X' call dqrot(dir, n, n, Q_d, n, c_d, s_d) call check_error('DQROT', 1) call reset() dir = 'F' call dqrot(dir, -1, n, Q_d, n, c_d, s_d) call check_error('DQROT', 2) call reset() call dqrot(dir, n, -1, Q_d, n, c_d, s_d) call check_error('DQROT', 3) call reset() call dqrot(dir, n, n, Q_d, n-1, c_d, s_d) call check_error('DQROT', 5) call reset() dir = 'X' call cqrot(dir, n, n, Q_c, n, c_c, s_c) call check_error('CQROT', 1) call reset() dir = 'F' call cqrot(dir, -1, n, Q_c, n, c_c, s_c) call check_error('CQROT', 2) call reset() call cqrot(dir, n, -1, Q_c, n, c_c, s_c) call check_error('CQROT', 3) call reset() call cqrot(dir, n, n, Q_c, n-1, c_c, s_c) call check_error('CQROT', 5) call reset() dir = 'X' call zqrot(dir, n, n, Q_z, n, c_z, s_z) call check_error('ZQROT', 1) call reset() dir = 'F' call zqrot(dir, -1, n, Q_z, n, c_z, s_z) call check_error('ZQROT', 2) call reset() call zqrot(dir, n, -1, Q_z, n, c_z, s_z) call check_error('ZQROT', 3) call reset() call zqrot(dir, n, n, Q_z, n-1, c_z, s_z) call check_error('ZQROT', 5) ! ====== QH factor ====== ! sqhqr(m,n,R,ldr,c,s): validates m>=0, n>=0, ldr>=m call reset() call sqhqr(-1, n, R_s, n, c_s, s_s) call check_error('SQHQR', 1) call reset() call sqhqr(n, -1, R_s, n, c_s, s_s) call check_error('SQHQR', 2) call reset() call sqhqr(n, n, R_s, n-1, c_s, s_s) call check_error('SQHQR', 4) call reset() call dqhqr(-1, n, R_d, n, c_d, s_d) call check_error('DQHQR', 1) call reset() call dqhqr(n, -1, R_d, n, c_d, s_d) call check_error('DQHQR', 2) call reset() call dqhqr(n, n, R_d, n-1, c_d, s_d) call check_error('DQHQR', 4) call reset() call cqhqr(-1, n, R_c, n, c_c, s_c) call check_error('CQHQR', 1) call reset() call cqhqr(n, -1, R_c, n, c_c, s_c) call check_error('CQHQR', 2) call reset() call cqhqr(n, n, R_c, n-1, c_c, s_c) call check_error('CQHQR', 4) call reset() call zqhqr(-1, n, R_z, n, c_z, s_z) call check_error('ZQHQR', 1) call reset() call zqhqr(n, -1, R_z, n, c_z, s_z) call check_error('ZQHQR', 2) call reset() call zqhqr(n, n, R_z, n-1, c_z, s_z) call check_error('ZQHQR', 4) ! ====== QR-QH ====== ! sqrqh(m,n,R,ldr,c,s): validates m>=0, n>=0, ldr>=m call reset() call sqrqh(-1, n, R_s, n, c_s, s_s) call check_error('SQRQH', 1) call reset() call sqrqh(n, -1, R_s, n, c_s, s_s) call check_error('SQRQH', 2) call reset() call sqrqh(n, n, R_s, n-1, c_s, s_s) call check_error('SQRQH', 4) call reset() call dqrqh(-1, n, R_d, n, c_d, s_d) call check_error('DQRQH', 1) call reset() call dqrqh(n, -1, R_d, n, c_d, s_d) call check_error('DQRQH', 2) call reset() call dqrqh(n, n, R_d, n-1, c_d, s_d) call check_error('DQRQH', 4) call reset() call cqrqh(-1, n, R_c, n, c_c, s_c) call check_error('CQRQH', 1) call reset() call cqrqh(n, -1, R_c, n, c_c, s_c) call check_error('CQRQH', 2) call reset() call cqrqh(n, n, R_c, n-1, c_c, s_c) call check_error('CQRQH', 4) call reset() call zqrqh(-1, n, R_z, n, c_z, s_z) call check_error('ZQRQH', 1) call reset() call zqrqh(n, -1, R_z, n, c_z, s_z) call check_error('ZQRQH', 2) call reset() call zqrqh(n, n, R_z, n-1, c_z, s_z) call check_error('ZQRQH', 4) ! ====== Givens Q vector ====== ! sgqvec(m,n,Q,ldq,u): validates m>=0, n>=0, ldq>=m call reset() call sgqvec(-1, n, Q_s, n, rhs_s) call check_error('SGQVEC', 1) call reset() call sgqvec(n, -1, Q_s, n, rhs_s) call check_error('SGQVEC', 2) call reset() call sgqvec(n, n, Q_s, n-1, rhs_s) call check_error('SGQVEC', 4) call reset() call dgqvec(-1, n, Q_d, n, rhs_d) call check_error('DGQVEC', 1) call reset() call dgqvec(n, -1, Q_d, n, rhs_d) call check_error('DGQVEC', 2) call reset() call dgqvec(n, n, Q_d, n-1, rhs_d) call check_error('DGQVEC', 4) call reset() call cgqvec(-1, n, Q_c, n, rhs_c) call check_error('CGQVEC', 1) call reset() call cgqvec(n, -1, Q_c, n, rhs_c) call check_error('CGQVEC', 2) call reset() call cgqvec(n, n, Q_c, n-1, rhs_c) call check_error('CGQVEC', 4) call reset() call zgqvec(-1, n, Q_z, n, rhs_z) call check_error('ZGQVEC', 1) call reset() call zgqvec(n, -1, Q_z, n, rhs_z) call check_error('ZGQVEC', 2) call reset() call zgqvec(n, n, Q_z, n-1, rhs_z) call check_error('ZGQVEC', 4) print *, 'All validation tests passed!' contains subroutine check_error(expected_name, expected_code) character(len=*), intent(in) :: expected_name integer, intent(in) :: expected_code if (.not. xerbla_called) then print '(A)', 'FAIL: xerbla not called for '//expected_name stop 1 end if if (last_srname /= expected_name) then print '(A,A,A,I0)', 'FAIL: expected srname "', expected_name, '" but got "', trim(last_srname), '"' stop 1 end if if (last_info /= expected_code) then print '(A,A,A,I0,A,I0)', 'FAIL: expected info=', expected_name, ' but got info=', last_info stop 1 end if print '(A,A,A,I0)', 'PASS: ', trim(expected_name), ' info=', last_info end subroutine check_error subroutine pxerbla(srname, info, aux) use test_state implicit none character(len=*), intent(in) :: srname integer, intent(in) :: info class(*), intent(in), optional :: aux xerbla_called = .true. last_srname = trim(srname) last_info = info end subroutine pxerbla end program test_qrupdate_validation qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/test_state.f90000066400000000000000000000022741522610125300245750ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! module test_state implicit none logical :: xerbla_called = .false. logical :: custom_handler_called = .false. character(len=64) :: last_srname = '' integer :: last_info = 0 integer :: call_count = 0 contains subroutine reset() xerbla_called = .false. custom_handler_called = .false. last_srname = '' last_info = 0 call_count = 0 end subroutine reset end module test_state qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tgqvec.f90000066400000000000000000000522301522610125300237040ustar00rootroot00000000000000! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tgqvec use iso_fortran_env implicit none integer :: m, n, passed, failed integer :: i real(real32) :: slamch real(real64) :: dlamch external :: slamch, dlamch common /stats/ passed, failed passed = 0 failed = 0 write(*,*) write(*,*) 'Testing gqvec routines.' write(*,*) write(*,1000) ! Test cases: (m, n) pairs ! - n = 0: trivial case, u should be e_1 ! - n = 1: orthogonal complement is m-1 dimensional ! - n = m-1: orthogonal complement is 1 dimensional ! - n = m div 2: moderate complement dimension ! - n = m div 2 - 1: slightly smaller complement ! - large m: stress test do i = 1, 6 select case (i) case (1) m = 10 n = 0 case (2) m = 10 n = 1 case (3) m = 10 n = m - 1 case (4) m = 10 n = m / 2 case (5) m = 10 n = m / 2 - 1 case (6) m = 100 n = 50 end select write(*,*) 'Test case (m,n) = (', m, ',', n, '):' call stest(m, n) call dtest(m, n) call ctest(m, n) call ztest(m, n) end do write(*,1000) write(*,1001) passed, failed write(*,*) if (failed .ne. 0) stop 1 1000 format(70('-')) 1001 format('total:', 1x, 'PASSED', 1x, I6, 1x, 'FAILED', 1x, I6) end program tgqvec ! Convert integer to string subroutine int2str(n, s) integer, intent(in) :: n character(len=*), intent(out) :: s character(len=12) :: tmp write(tmp, '(I12)') n s = adjustl(tmp) end subroutine int2str subroutine stest(m, n) use iso_fortran_env integer, intent(in) :: m, n real(real32), allocatable :: A(:,:), Q(:,:), R(:,:), u(:), Qcheck(:,:) real(real32) :: slamch, tol integer :: j character(len=40) :: lbl integer :: passed, failed common /stats/ passed, failed external :: sgqvec, srandg, sqrgen, slamch real(real32) :: sdot, snrm2 allocate(A(m, m), Q(m, m), R(m, m), u(m), Qcheck(m+3, m)) call srandg(m, n, A, m) call sqrgen(m, n, A, m, Q, m, R, m) ! Test with ldq = m (tight packing) call sgqvec(m, n, Q, m, u) tol = 5e2 * slamch('p') call int2str(m, lbl) if (n == 0) then call check_unit_vector_s(m, u, tol, 's (n=0, ldq=' // lbl // ')') else call check_orthogonal_s(m, n, Q, m, u, tol, 's (n>0, ldq=' // lbl // ')') call check_unit_norm_s(m, u, tol, 's (n>0, ldq=' // lbl // ')') end if ! Test with ldq > m (leading dimension padding) do j = 1, 3 call srandg(m, n, A, m) call sqrgen(m, n, A, m, Q, m, R, m) if (n == 0) then call sgqvec(m, n, Q, m+j, u) tol = 5e2 * slamch('p') call int2str(m + j, lbl) call check_unit_vector_s(m, u, tol, 's (n=0, ldq=' // lbl // ')') else call sgqvec_ldq(m, n, Q, m+j, u, Qcheck) tol = 5e2 * slamch('p') call int2str(m + j, lbl) call check_orthogonal_s(m, n, Qcheck, m+j, u, tol, 's (n>0, ldq=' // lbl // ')') call check_unit_norm_s(m, u, tol, 's (n>0, ldq=' // lbl // ')') end if end do deallocate(A, Q, R, u) end subroutine stest subroutine dtest(m, n) use iso_fortran_env integer, intent(in) :: m, n real(real64), allocatable :: A(:,:), Q(:,:), R(:,:), u(:), Qcheck(:,:) real(real64) :: dlamch, tol integer :: j character(len=40) :: lbl integer :: passed, failed common /stats/ passed, failed external :: dgqvec, drandg, dqrgen, dlamch real(real64) :: ddot, dnrm2 allocate(A(m, m), Q(m, m), R(m, m), u(m), Qcheck(m+3, m)) call drandg(m, n, A, m) call dqrgen(m, n, A, m, Q, m, R, m) call dgqvec(m, n, Q, m, u) tol = 5d2 * dlamch('p') call int2str(m, lbl) if (n == 0) then call check_unit_vector_d(m, u, tol, 'd (n=0, ldq=' // lbl // ')') else call check_orthogonal_d(m, n, Q, m, u, tol, 'd (n>0, ldq=' // lbl // ')') call check_unit_norm_d(m, u, tol, 'd (n>0, ldq=' // lbl // ')') end if ! Test with ldq > m do j = 1, 3 call drandg(m, n, A, m) call dqrgen(m, n, A, m, Q, m, R, m) if (n == 0) then call dgqvec(m, n, Q, m+j, u) tol = 5d2 * dlamch('p') call int2str(m + j, lbl) call check_unit_vector_d(m, u, tol, 'd (n=0, ldq=' // lbl // ')') else call dgqvec_ldq(m, n, Q, m+j, u, Qcheck) tol = 5d2 * dlamch('p') call int2str(m + j, lbl) call check_orthogonal_d(m, n, Qcheck, m+j, u, tol, 'd (n>0, ldq=' // lbl // ')') call check_unit_norm_d(m, u, tol, 'd (n>0, ldq=' // lbl // ')') end if end do deallocate(A, Q, R, u) end subroutine dtest subroutine ctest(m, n) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m, n complex(real32), allocatable :: A(:,:), Q(:,:), R(:,:), u(:), Qcheck(:,:) real(real32) :: slamch, tol integer :: j character(len=40) :: lbl integer :: passed, failed common /stats/ passed, failed external :: cgqvec, crandg, cqrgen allocate(A(m, m), Q(m, m), R(m, m), u(m), Qcheck(m+3, m)) call crandg(m, n, A, m) call cqrgen(m, n, A, m, Q, m, R, m) call cgqvec(m, n, Q, m, u) tol = 5e2 * slamch('p') call int2str(m, lbl) if (n == 0) then call check_unit_vector_c(m, u, tol, 'c (n=0, ldq=' // lbl // ')') else call check_orthogonal_c(m, n, Q, m, u, tol, 'c (n>0, ldq=' // lbl // ')') call check_unit_norm_c(m, u, tol, 'c (n>0, ldq=' // lbl // ')') end if ! Test with ldq > m do j = 1, 3 call crandg(m, n, A, m) call cqrgen(m, n, A, m, Q, m, R, m) if (n == 0) then call cgqvec(m, n, Q, m+j, u) tol = 5e2 * slamch('p') call int2str(m + j, lbl) call check_unit_vector_c(m, u, tol, 'c (n=0, ldq=' // lbl // ')') else call cgqvec_ldq(m, n, Q, m+j, u, Qcheck) tol = 5e2 * slamch('p') call int2str(m + j, lbl) call check_orthogonal_c(m, n, Qcheck, m+j, u, tol, 'c (n>0, ldq=' // lbl // ')') call check_unit_norm_c(m, u, tol, 'c (n>0, ldq=' // lbl // ')') end if end do deallocate(A, Q, R, u) end subroutine ctest subroutine ztest(m, n) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m, n complex(real64), allocatable :: A(:,:), Q(:,:), R(:,:), u(:), Qcheck(:,:) real(real64) :: dlamch, tol integer :: j character(len=40) :: lbl integer :: passed, failed common /stats/ passed, failed external :: zgqvec, zrandg, zqrgen allocate(A(m, m), Q(m, m), R(m, m), u(m), Qcheck(m+3, m)) call zrandg(m, n, A, m) call zqrgen(m, n, A, m, Q, m, R, m) call zgqvec(m, n, Q, m, u) tol = 5d2 * dlamch('p') call int2str(m, lbl) if (n == 0) then call check_unit_vector_z(m, u, tol, 'z (n=0, ldq=' // lbl // ')') else call check_orthogonal_z(m, n, Q, m, u, tol, 'z (n>0, ldq=' // lbl // ')') call check_unit_norm_z(m, u, tol, 'z (n>0, ldq=' // lbl // ')') end if ! Test with ldq > m do j = 1, 3 call zrandg(m, n, A, m) call zqrgen(m, n, A, m, Q, m, R, m) if (n == 0) then call zgqvec(m, n, Q, m+j, u) tol = 5d2 * dlamch('p') call int2str(m + j, lbl) call check_unit_vector_z(m, u, tol, 'z (n=0, ldq=' // lbl // ')') else call zgqvec_ldq(m, n, Q, m+j, u, Qcheck) tol = 5d2 * dlamch('p') call int2str(m + j, lbl) call check_orthogonal_z(m, n, Qcheck, m+j, u, tol, 'z (n>0, ldq=' // lbl // ')') call check_unit_norm_z(m, u, tol, 'z (n>0, ldq=' // lbl // ')') end if end do deallocate(A, Q, R, u) end subroutine ztest ! Helper: call gqvec with a padded Q buffer for ldq > m. ! Creates Qpad(ldq, n) with Q in the first m rows, calls gqvec, returns Qpad via Qout. subroutine sgqvec_ldq(m, n, Q, ldq, u, Qout) use iso_fortran_env integer, intent(in) :: m, n, ldq real(real32), intent(in) :: Q(m, *) real(real32), intent(out) :: u(m) real(real32), intent(out) :: Qout(ldq, n) external sgqvec if (n == 0) then call sgqvec(m, n, Q, ldq, u) return end if Qout = 0e0 Qout(1:m, 1:n) = Q(1:m, 1:n) call sgqvec(m, n, Qout, ldq, u) end subroutine sgqvec_ldq subroutine dgqvec_ldq(m, n, Q, ldq, u, Qout) use iso_fortran_env integer, intent(in) :: m, n, ldq real(real64), intent(in) :: Q(m, *) real(real64), intent(out) :: u(m) real(real64), intent(out) :: Qout(ldq, n) external dgqvec if (n == 0) then call dgqvec(m, n, Q, ldq, u) return end if Qout = 0d0 Qout(1:m, 1:n) = Q(1:m, 1:n) call dgqvec(m, n, Qout, ldq, u) end subroutine dgqvec_ldq subroutine cgqvec_ldq(m, n, Q, ldq, u, Qout) use iso_fortran_env integer, intent(in) :: m, n, ldq complex(real32), intent(in) :: Q(m, *) complex(real32), intent(out) :: u(m) complex(real32), intent(out) :: Qout(ldq, n) external cgqvec if (n == 0) then call cgqvec(m, n, Q, ldq, u) return end if Qout = (0e0, 0e0) Qout(1:m, 1:n) = Q(1:m, 1:n) call cgqvec(m, n, Qout, ldq, u) end subroutine cgqvec_ldq subroutine zgqvec_ldq(m, n, Q, ldq, u, Qout) use iso_fortran_env integer, intent(in) :: m, n, ldq complex(real64), intent(in) :: Q(m, *) complex(real64), intent(out) :: u(m) complex(real64), intent(out) :: Qout(ldq, n) external zgqvec if (n == 0) then call zgqvec(m, n, Q, ldq, u) return end if Qout = (0d0, 0d0) Qout(1:m, 1:n) = Q(1:m, 1:n) call zgqvec(m, n, Qout, ldq, u) end subroutine zgqvec_ldq ! Check that u is approximately the first canonical unit vector e_1 subroutine check_unit_vector_s(m, u, tol, label) use iso_fortran_env integer, intent(in) :: m real(real32), intent(in) :: u(m) real(real32), intent(in) :: tol character(*), intent(in) :: label real(real32) :: err integer :: passed, failed common /stats/ passed, failed external :: snrm2 real(real32) :: snrm2 character(6) :: result err = abs(u(1) - 1e0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'u(1)=1 :', err, result if (m > 1) then err = snrm2(m - 1, u(2), 1) else err = 0e0 end if if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1002) trim(label), 'u(2:m)=0:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) 1002 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_vector_s subroutine check_unit_vector_d(m, u, tol, label) use iso_fortran_env integer, intent(in) :: m real(real64), intent(in) :: u(m) real(real64), intent(in) :: tol character(*), intent(in) :: label real(real64) :: err integer :: passed, failed common /stats/ passed, failed external :: dnrm2 real(real64) :: dnrm2 character(6) :: result err = abs(u(1) - 1d0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'u(1)=1 :', err, result if (m > 1) then err = dnrm2(m - 1, u(2), 1) else err = 0d0 end if if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1002) trim(label), 'u(2:m)=0:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) 1002 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_vector_d subroutine check_unit_vector_c(m, u, tol, label) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m complex(real32), intent(in) :: u(m) real(real32), intent(in) :: tol character(*), intent(in) :: label real(real32) :: err integer :: passed, failed common /stats/ passed, failed external :: scnrm2 real(real32) :: scnrm2 character(6) :: result err = abs(abs(u(1)) - 1e0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), '|u(1)|=1:', err, result if (m > 1) then err = scnrm2(m - 1, u(2), 1) else err = 0e0 end if if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1002) trim(label), 'u(2:m)=0:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) 1002 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_vector_c subroutine check_unit_vector_z(m, u, tol, label) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m complex(real64), intent(in) :: u(m) real(real64), intent(in) :: tol character(*), intent(in) :: label real(real64) :: err integer :: passed, failed common /stats/ passed, failed external :: dznrm2 real(real64) :: dznrm2 character(6) :: result err = abs(abs(u(1)) - 1d0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), '|u(1)|=1:', err, result if (m > 1) then err = dznrm2(m - 1, u(2), 1) else err = 0d0 end if if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1002) trim(label), 'u(2:m)=0:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) 1002 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_vector_z subroutine check_orthogonal_s(m, n, Q, ldq, u, tol, label) use iso_fortran_env integer, intent(in) :: m, n, ldq real(real32), intent(in) :: Q(ldq, n), u(m) real(real32), intent(in) :: tol character(*), intent(in) :: label real(real32) :: prod, err integer :: passed, failed common /stats/ passed, failed external :: sdot real(real32) :: sdot integer :: i character(6) :: result err = 0e0 do i = 1, n prod = sdot(m, Q(1, i), 1, u, 1) if (abs(prod) > err) err = abs(prod) end do if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'max|Q''u|:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_orthogonal_s subroutine check_orthogonal_d(m, n, Q, ldq, u, tol, label) use iso_fortran_env integer, intent(in) :: m, n, ldq real(real64), intent(in) :: Q(ldq, n), u(m) real(real64), intent(in) :: tol character(*), intent(in) :: label real(real64) :: prod, err integer :: passed, failed common /stats/ passed, failed external :: ddot real(real64) :: ddot integer :: i character(6) :: result err = 0d0 do i = 1, n prod = ddot(m, Q(1, i), 1, u, 1) if (abs(prod) > err) err = abs(prod) end do if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'max|Q''u|:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_orthogonal_d subroutine check_orthogonal_c(m, n, Q, ldq, u, tol, label) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m, n, ldq complex(real32), intent(in) :: Q(ldq, n), u(m) real(real32), intent(in) :: tol character(*), intent(in) :: label real(real32) :: err, rr complex(real32) :: rc integer :: i integer :: passed, failed common /stats/ passed, failed character(6) :: result err = 0e0 do i = 1, n call qrupdate_cdotc(rc, m, Q(1, i), 1, u, 1) rr = sqrt(real(rc, real32)**2 + aimag(rc)**2) if (rr > err) err = rr end do if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'max|Q''u|:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_orthogonal_c subroutine check_orthogonal_z(m, n, Q, ldq, u, tol, label) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m, n, ldq complex(real64), intent(in) :: Q(ldq, n), u(m) real(real64), intent(in) :: tol character(*), intent(in) :: label real(real64) :: err, rr complex(real64) :: rc integer :: i integer :: passed, failed common /stats/ passed, failed character(6) :: result err = 0d0 do i = 1, n call qrupdate_zdotc(rc, m, Q(1, i), 1, u, 1) rr = dsqrt(real(rc, real64)**2 + aimag(rc)**2) if (rr > err) err = rr end do if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'max|Q''u|:', err, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_orthogonal_z subroutine check_unit_norm_s(m, u, tol, label) use iso_fortran_env integer, intent(in) :: m real(real32), intent(in) :: u(m) real(real32), intent(in) :: tol character(*), intent(in) :: label real(real32) :: unrm, err integer :: passed, failed common /stats/ passed, failed external :: snrm2 real(real32) :: snrm2 character(6) :: result unrm = snrm2(m, u, 1) err = abs(unrm - 1e0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'norm(u) :', unrm, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_norm_s subroutine check_unit_norm_d(m, u, tol, label) use iso_fortran_env integer, intent(in) :: m real(real64), intent(in) :: u(m) real(real64), intent(in) :: tol character(*), intent(in) :: label real(real64) :: unrm, err integer :: passed, failed common /stats/ passed, failed external :: dnrm2 real(real64) :: dnrm2 character(6) :: result unrm = dnrm2(m, u, 1) err = abs(unrm - 1d0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'norm(u) :', unrm, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_norm_d subroutine check_unit_norm_c(m, u, tol, label) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m complex(real32), intent(in) :: u(m) real(real32), intent(in) :: tol character(*), intent(in) :: label real(real32) :: unrm, err integer :: passed, failed common /stats/ passed, failed external :: scnrm2 real(real32) :: scnrm2 character(6) :: result unrm = scnrm2(m, u, 1) err = abs(unrm - 1e0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'norm(u) :', unrm, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_norm_c subroutine check_unit_norm_z(m, u, tol, label) use iso_fortran_env use qrupdate_blas integer, intent(in) :: m complex(real64), intent(in) :: u(m) real(real64), intent(in) :: tol character(*), intent(in) :: label real(real64) :: unrm, err integer :: passed, failed common /stats/ passed, failed external :: dznrm2 real(real64) :: dznrm2 character(6) :: result unrm = dznrm2(m, u, 1) err = abs(unrm - 1d0) if (err > tol) then result = 'FAIL' failed = failed + 1 else result = 'PASS' passed = passed + 1 end if write(*, 1001) trim(label), 'norm(u) :', unrm, result return 1001 format(' ', A, 1x, A10, E12.4, 1x, A4) end subroutine check_unit_norm_z qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tlu1up.f90000066400000000000000000000076221522610125300236520ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tlu1up integer m,n external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing LU rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 write (*,*) 'slu1up test (rows > columns):' call stest(m,n) write (*,*) 'dlu1up test (rows > columns):' call dtest(m,n) write (*,*) 'clu1up test (rows > columns):' call ctest(m,n) write (*,*) 'zlu1up test (rows > columns):' call ztest(m,n) m = 40 n = 60 write (*,*) 'slu1up test (rows < columns):' call stest(m,n) write (*,*) 'dlu1up test (rows < columns):' call dtest(m,n) write (*,*) 'clu1up test (rows < columns):' call ctest(m,n) write (*,*) 'zlu1up test (rows < columns):' call ztest(m,n) call pstats end program subroutine stest(m,n) use iso_fortran_env integer m,n real(real32) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external srandg,slugen,sger,slu1up,sluchk integer k ! set up random matrix & vectors call srandg(m,n,A,m) call srandg(m,1,u,m) call srandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call slugen(m,n,A,m,L,m,R,k) ! update A call sger(m,n,1e0,u,1,v,1,A,m) ! update the LU decomposition call slu1up(m,n,L,m,R,k,u,v) ! check result call sluchk(m,n,A,m,L,m,R,k) end subroutine subroutine dtest(m,n) use iso_fortran_env integer m,n real(real64) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external drandg,dlugen,dger,dlu1up,dluchk integer k ! set up random matrix & vectors call drandg(m,n,A,m) call drandg(m,1,u,m) call drandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call dlugen(m,n,A,m,L,m,R,k) ! update A call dger(m,n,1d0,u,1,v,1,A,m) ! update the LU decomposition call dlu1up(m,n,L,m,R,k,u,v) ! check result call dluchk(m,n,A,m,L,m,R,k) end subroutine subroutine ctest(m,n) use iso_fortran_env integer m,n complex(real32) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external crandg,clugen,cgeru,clu1up,cluchk integer k ! set up random matrix & vectors call crandg(m,n,A,m) call crandg(m,1,u,m) call crandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call clugen(m,n,A,m,L,m,R,k) ! update A call cgeru(m,n,(1e0,0e0),u,1,v,1,A,m) ! update the LU decomposition call clu1up(m,n,L,m,R,k,u,v) ! check result call cluchk(m,n,A,m,L,m,R,k) end subroutine subroutine ztest(m,n) use iso_fortran_env integer m,n complex(real64) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external zrandg,zlugen,zgeru,zlu1up,zluchk integer k ! set up random matrix & vectors call zrandg(m,n,A,m) call zrandg(m,1,u,m) call zrandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call zlugen(m,n,A,m,L,m,R,k) ! update A call zgeru(m,n,(1d0,0d0),u,1,v,1,A,m) ! update the LU decomposition call zlu1up(m,n,L,m,R,k,u,v) ! check result call zluchk(m,n,A,m,L,m,R,k) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tlup1up.f90000066400000000000000000000101661522610125300240270ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tlup1up integer m,n external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing pivoted LU rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 write (*,*) 'slup1up test (rows > columns):' call stest(m,n) write (*,*) 'dlup1up test (rows > columns):' call dtest(m,n) write (*,*) 'clup1up test (rows > columns):' call ctest(m,n) write (*,*) 'zlup1up test (rows > columns):' call ztest(m,n) m = 40 n = 60 write (*,*) 'slup1up test (rows < columns):' call stest(m,n) write (*,*) 'dlup1up test (rows < columns):' call dtest(m,n) write (*,*) 'clup1up test (rows < columns):' call ctest(m,n) write (*,*) 'zlup1up test (rows < columns):' call ztest(m,n) call pstats end program subroutine stest(m,n) use iso_fortran_env integer m,n real(real32) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external srandg,slupgen,sger,slup1up,slupchk integer k,p(m) ! set up random matrix & vectors call srandg(m,n,A,m) call srandg(m,1,u,m) call srandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call slupgen(m,n,A,m,L,m,R,k,p) ! update A call sger(m,n,1e0,u,1,v,1,A,m) ! update the pivoted LU decomposition call slup1up(m,n,L,m,R,k,p,u,v,w) ! check result call slupchk(m,n,A,m,L,m,R,k,p) end subroutine subroutine dtest(m,n) use iso_fortran_env integer m,n real(real64) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external drandg,dlupgen,dger,dlup1up,dlupchk integer k,p(m) ! set up random matrix & vectors A = 0.0D0 L = 0.0D0 R = 0.0D0 u = 0.0D0 v = 0.0D0 w = 0.0D0 call drandg(m,n,A,m) call drandg(m,1,u,m) call drandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call dlupgen(m,n,A,m,L,m,R,k,p) ! update A call dger(m,n,1d0,u,1,v,1,A,m) ! update the pivoted LU decomposition call dlup1up(m,n,L,m,R,k,p,u,v,w) ! check result call dlupchk(m,n,A,m,L,m,R,k,p) end subroutine subroutine ctest(m,n) use iso_fortran_env integer m,n complex(real32) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external crandg,clupgen,cgeru,clup1up,clupchk integer k,p(m) ! set up random matrix & vectors call crandg(m,n,A,m) call crandg(m,1,u,m) call crandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call clupgen(m,n,A,m,L,m,R,k,p) ! update A call cgeru(m,n,(1e0,0e0),u,1,v,1,A,m) ! update the pivoted LU decomposition call clup1up(m,n,L,m,R,k,p,u,v,w) ! check result call clupchk(m,n,A,m,L,m,R,k,p) end subroutine subroutine ztest(m,n) use iso_fortran_env integer m,n complex(real64) A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external zrandg,zlupgen,zgeru,zlup1up,zlupchk integer k,p(m) ! set up random matrix & vectors call zrandg(m,n,A,m) call zrandg(m,1,u,m) call zrandg(n,1,v,n) k = min(m,n) ! generate LU decomposition call zlupgen(m,n,A,m,L,m,R,k,p) ! update A call zgeru(m,n,(1d0,0d0),u,1,v,1,A,m) ! update the pivoted LU decomposition call zlup1up(m,n,L,m,R,k,p,u,v,w) ! check result call zlupchk(m,n,A,m,L,m,R,k,p) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tqr1up.f90000066400000000000000000000106531522610125300236520ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tqr1up integer m,n external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 write (*,*) 'sqr1up test (full factorization):' call stest(m,n,0) write (*,*) 'dqr1up test (full factorization):' call dtest(m,n,0) write (*,*) 'cqr1up test (full factorization):' call ctest(m,n,0) write (*,*) 'zqr1up test (full factorization):' call ztest(m,n,0) write (*,*) 'sqr1up test (economized factorization):' call stest(m,n,1) write (*,*) 'dqr1up test (economized factorization):' call dtest(m,n,1) write (*,*) 'cqr1up test (economized factorization):' call ctest(m,n,1) write (*,*) 'zqr1up test (economized factorization):' call ztest(m,n,1) m = 40 n = 60 write (*,*) 'sqr1up test (rows < columns):' call stest(m,n,0) write (*,*) 'dqr1up test (rows < columns):' call dtest(m,n,0) write (*,*) 'cqr1up test (rows < columns):' call ctest(m,n,0) write (*,*) 'zqr1up test (rows < columns):' call ztest(m,n,0) call pstats end program subroutine stest(m,n,ec) use iso_fortran_env integer m,n,ec real(real32) A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(2*m) external srandg,sqrgen,sger,sqr1up,sqrchk integer k ! set up random matrix & vectors call srandg(m,n,A,m) call srandg(m,1,u,m) call srandg(n,1,v,n) ! generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) ! update A call sger(m,n,1e0,u,1,v,1,A,m) ! update the QR decomposition k = m if (ec == 1) k = n call sqr1up(m,n,k,Q,m,R,m,u,v,wrk) ! check result call sqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,ec) use iso_fortran_env integer m,n,ec real(real64) A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(2*m) external drandg,dqrgen,dger,dqr1up,dqrchk integer k ! set up random matrix & vectors call drandg(m,n,A,m) call drandg(m,1,u,m) call drandg(n,1,v,n) ! generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) ! update A call dger(m,n,1d0,u,1,v,1,A,m) ! update the QR decomposition k = m if (ec == 1) k = n call dqr1up(m,n,k,Q,m,R,m,u,v,wrk) ! check result call dqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,ec) use iso_fortran_env integer m,n,ec complex(real32) A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(m) real(real32) rwrk(m) external crandg,cqrgen,cgerc,cqr1up,cqrchk integer k ! set up random matrix & vectors call crandg(m,n,A,m) call crandg(m,1,u,m) call crandg(n,1,v,n) ! generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) ! update A call cgerc(m,n,(1e0,0e0),u,1,v,1,A,m) ! update the QR decomposition k = m if (ec == 1) k = n call cqr1up(m,n,k,Q,m,R,m,u,v,wrk,rwrk) ! check result call cqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,ec) use iso_fortran_env integer m,n,ec complex(real64) A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(m) real(real64) rwrk(m) external zrandg,zqrgen,zgerc,zqr1up,zqrchk integer k ! set up random matrix & vectors call zrandg(m,n,A,m) call zrandg(m,1,u,m) call zrandg(n,1,v,n) ! generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) ! update A call zgerc(m,n,(1d0,0d0),u,1,v,1,A,m) ! update the QR decomposition k = m if (ec == 1) k = n call zqr1up(m,n,k,Q,m,R,m,u,v,wrk,rwrk) ! check result call zqrchk(m,n,k,A,m,Q,m,R,m) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tqrdec.f90000066400000000000000000000101411522610125300236700ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tqrdec integer m,n,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR column delete routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 12 write (*,*) 'sqrdec test (full factorization):' call stest(m,n,j,0) write (*,*) 'dqrdec test (full factorization):' call dtest(m,n,j,0) write (*,*) 'cqrdec test (full factorization):' call ctest(m,n,j,0) write (*,*) 'zqrdec test (full factorization):' call ztest(m,n,j,0) write (*,*) 'sqrdec test (economized factorization):' call stest(m,n,j,1) write (*,*) 'dqrdec test (economized factorization):' call dtest(m,n,j,1) write (*,*) 'cqrdec test (economized factorization):' call ctest(m,n,j,1) write (*,*) 'zqrdec test (economized factorization):' call ztest(m,n,j,1) call pstats end program subroutine stest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec real(real32) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external srandg,sqrgen,scopy,sqrdec,sqrchk integer k,i ! set up random matrix & vector call srandg(m,n,A,m) ! generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,n-1 call scopy(m,A(1,i+1),1,A(1,i),1) end do ! update the QR decomposition k = m if (ec == 1) k = n call sqrdec(m,n,k,Q,m,R,m,j,wrk) ! check result if (ec == 1) k = n+1 call sqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec real(real64) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external drandg,dqrgen,dcopy,dqrdec,dqrchk integer k,i ! set up random matrix & vector call drandg(m,n,A,m) ! generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,n-1 call dcopy(m,A(1,i+1),1,A(1,i),1) end do ! update the QR decomposition k = m if (ec == 1) k = n call dqrdec(m,n,k,Q,m,R,m,j,wrk) ! check result if (ec == 1) k = n+1 call dqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec complex(real32) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external crandg,cqrgen,ccopy,cqrdec,cqrchk integer k,i ! set up random matrix & vector call crandg(m,n,A,m) ! generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,n-1 call ccopy(m,A(1,i+1),1,A(1,i),1) end do ! update the QR decomposition k = m if (ec == 1) k = n call cqrdec(m,n,k,Q,m,R,m,j,wrk) ! check result if (ec == 1) k = n+1 call cqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec complex(real64) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external zrandg,zqrgen,zcopy,zqrdec,zqrchk integer k,i ! set up random matrix & vector call zrandg(m,n,A,m) ! generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,n-1 call zcopy(m,A(1,i+1),1,A(1,i),1) end do ! update the QR decomposition k = m if (ec == 1) k = n call zqrdec(m,n,k,Q,m,R,m,j,wrk) ! check result if (ec == 1) k = n+1 call zqrchk(m,n-1,k,A,m,Q,m,R,m) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tqrder.f90000066400000000000000000000071051522610125300237150ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tqrder integer m,n,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR row delete routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 30 write (*,*) 'sqrder test (full factorization):' call stest(m,n,j) write (*,*) 'dqrder test (full factorization):' call dtest(m,n,j) write (*,*) 'cqrder test (full factorization):' call ctest(m,n,j) write (*,*) 'zqrder test (full factorization):' call ztest(m,n,j) call pstats end program subroutine stest(m,n,j) use iso_fortran_env integer m,n,j real(real32) A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external srandg,sqrgen,scopy,sqrder,sqrchk integer i ! set up random matrix & vector call srandg(m,n,A,m) ! generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,m-1 call scopy(n,A(i+1,1),m,A(i,1),m) end do ! update the QR decomposition call sqrder(m,n,Q,m,R,m,j,wrk) ! check result call sqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,j) use iso_fortran_env integer m,n,j real(real64) A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external drandg,dqrgen,dcopy,dqrder,dqrchk integer i ! set up random matrix & vector call drandg(m,n,A,m) ! generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,m-1 call dcopy(n,A(i+1,1),m,A(i,1),m) end do ! update the QR decomposition call dqrder(m,n,Q,m,R,m,j,wrk) ! check result call dqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,j) use iso_fortran_env integer m,n,j complex(real32) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) real(real32) rwrk(m) external crandg,cqrgen,ccopy,cqrder,cqrchk integer i ! set up random matrix & vector call crandg(m,n,A,m) ! generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,m-1 call ccopy(n,A(i+1,1),m,A(i,1),m) end do ! update the QR decomposition call cqrder(m,n,Q,m,R,m,j,wrk,rwrk) ! check result call cqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,j) use iso_fortran_env integer m,n,j complex(real64) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) real(real64) rwrk(m) external zrandg,zqrgen,zcopy,zqrder,zqrchk integer i ! set up random matrix & vector call zrandg(m,n,A,m) ! generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) ! update A do i = j,m-1 call zcopy(n,A(i+1,1),m,A(i,1),m) end do ! update the QR decomposition call zqrder(m,n,Q,m,R,m,j,wrk,rwrk) ! check result call zqrchk(m-1,n,m-1,A,m,Q,m,R,m) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tqrinc.f90000066400000000000000000000105611522610125300237140ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tqrinc integer m,n,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR column insert routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 28 write (*,*) 'sqrinc test (full factorization):' call stest(m,n,j,0) write (*,*) 'dqrinc test (full factorization):' call dtest(m,n,j,0) write (*,*) 'cqrinc test (full factorization):' call ctest(m,n,j,0) write (*,*) 'zqrinc test (full factorization):' call ztest(m,n,j,0) write (*,*) 'sqrinc test (economized factorization):' call stest(m,n,j,1) write (*,*) 'dqrinc test (economized factorization):' call dtest(m,n,j,1) write (*,*) 'cqrinc test (economized factorization):' call ctest(m,n,j,1) write (*,*) 'zqrinc test (economized factorization):' call ztest(m,n,j,1) call pstats end program subroutine stest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec real(real32) A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external srandg,sqrgen,scopy,sqrinc,sqrchk integer k,i ! set up random matrix & vector call srandg(m,n,A,m) call srandg(m,1,u,m) ! generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) ! update A do i = n,j,-1 call scopy(m,A(1,i),1,A(1,i+1),1) end do call scopy(m,u,1,A(1,j),1) ! update the QR decomposition k = m if (ec == 1) k = n call sqrinc(m,n,k,Q,m,R,m,j,u,wrk) ! check result if (ec == 1) k = n+1 call sqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec real(real64) A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external drandg,dqrgen,dcopy,dqrinc,dqrchk integer k,i ! set up random matrix & vector call drandg(m,n,A,m) call drandg(m,1,u,m) ! generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) ! update A do i = n,j,-1 call dcopy(m,A(1,i),1,A(1,i+1),1) end do call dcopy(m,u,1,A(1,j),1) ! update the QR decomposition k = m if (ec == 1) k = n call dqrinc(m,n,k,Q,m,R,m,j,u,wrk) ! check result if (ec == 1) k = n+1 call dqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec complex(real32) A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external crandg,cqrgen,ccopy,cqrinc,cqrchk integer k,i ! set up random matrix & vector call crandg(m,n,A,m) call crandg(m,1,u,m) ! generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) ! update A do i = n,j,-1 call ccopy(m,A(1,i),1,A(1,i+1),1) end do call ccopy(m,u,1,A(1,j),1) ! update the QR decomposition k = m if (ec == 1) k = n call cqrinc(m,n,k,Q,m,R,m,j,u,wrk) ! check result if (ec == 1) k = n+1 call cqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,j,ec) use iso_fortran_env integer m,n,j,ec complex(real64) A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external zrandg,zqrgen,zcopy,zqrinc,zqrchk integer k,i ! set up random matrix & vector call zrandg(m,n,A,m) call zrandg(m,1,u,m) ! generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) ! update A do i = n,j,-1 call zcopy(m,A(1,i),1,A(1,i+1),1) end do call zcopy(m,u,1,A(1,j),1) ! update the QR decomposition k = m if (ec == 1) k = n call zqrinc(m,n,k,Q,m,R,m,j,u,wrk) ! check result if (ec == 1) k = n+1 call zqrchk(m,n+1,k,A,m,Q,m,R,m) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tqrinr.f90000066400000000000000000000076151522610125300237410ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tqrinr integer m,n,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR row insert routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 30 write (*,*) 'sqrinr test (full factorization):' call stest(m,n,j) write (*,*) 'dqrinr test (full factorization):' call dtest(m,n,j) write (*,*) 'cqrinr test (full factorization):' call ctest(m,n,j) write (*,*) 'zqrinr test (full factorization):' call ztest(m,n,j) call pstats end program subroutine stest(m,n,j) use iso_fortran_env integer m,n,j real(real32) A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external srandg,sqrgen,scopy,sqrinr,sqrchk integer i ! set up random matrix & vector call srandg(m,n,A,m+1) call srandg(n,1,u,n) ! generate QR decomposition call sqrgen(m,n,A,m+1,Q,m+1,R,m+1) ! update A do i = m,j,-1 call scopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call scopy(n,u,1,A(j,1),m+1) ! update the QR decomposition call sqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) ! check result call sqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine subroutine dtest(m,n,j) use iso_fortran_env integer m,n,j real(real64) A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external drandg,dqrgen,dcopy,dqrinr,dqrchk integer i ! set up random matrix & vector call drandg(m,n,A,m+1) call drandg(n,1,u,n) ! generate QR decomposition call dqrgen(m,n,A,m+1,Q,m+1,R,m+1) ! update A do i = m,j,-1 call dcopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call dcopy(n,u,1,A(j,1),m+1) ! update the QR decomposition call dqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) ! check result call dqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine subroutine ctest(m,n,j) use iso_fortran_env integer m,n,j complex(real32) A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external crandg,cqrgen,ccopy,cqrinr,cqrchk integer i ! set up random matrix & vector call crandg(m,n,A,m+1) call crandg(n,1,u,n) ! generate QR decomposition call cqrgen(m,n,A,m+1,Q,m+1,R,m+1) ! update A do i = m,j,-1 call ccopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call ccopy(n,u,1,A(j,1),m+1) ! update the QR decomposition call cqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) ! check result call cqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine subroutine ztest(m,n,j) use iso_fortran_env integer m,n,j complex(real64) A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external zrandg,zqrgen,zcopy,zqrinr,zqrchk integer i ! set up random matrix & vector call zrandg(m,n,A,m+1) call zrandg(n,1,u,n) ! generate QR decomposition call zqrgen(m,n,A,m+1,Q,m+1,R,m+1) ! update A do i = m,j,-1 call zcopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call zcopy(n,u,1,A(j,1),m+1) ! update the QR decomposition call zqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) ! check result call zqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/tqrshc.f90000066400000000000000000000125171522610125300237230ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! program tqrshc integer m,n,i,j external stest, dtest, ctest, ztest, pstats write (*,*) write (*,*) 'testing QR column shift routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 50 i = 20 j = 40 write (*,*) 'sqrshc test (left shift, full factorization):' call stest(m,n,i,j,0) write (*,*) 'dqrshc test (left shift, full factorization):' call dtest(m,n,i,j,0) write (*,*) 'cqrshc test (left shift, full factorization):' call ctest(m,n,i,j,0) write (*,*) 'zqrshc test (left shift, full factorization):' call ztest(m,n,i,j,0) i = 40 j = 20 write (*,*) 'sqrshc test (right shift, economized factorization):' call stest(m,n,i,j,1) write (*,*) 'dqrshc test (right shift, economized factorization):' call dtest(m,n,i,j,1) write (*,*) 'cqrshc test (right shift, economized factorization):' call ctest(m,n,i,j,1) write (*,*) 'zqrshc test (right shift, economized factorization):' call ztest(m,n,i,j,1) call pstats end program subroutine stest(m,n,i,j,ec) use iso_fortran_env integer m,n,i,j,ec real(real32) A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external srandg,sqrgen,scopy,sqrshc,sqrchk integer k ! set up random matrix & vector call srandg(m,n,A,m) ! generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) ! update A if (i < j) then call scopy(m,A(1,i),1,wrk,1) do k = i,j-1 call scopy(m,A(1,k+1),1,A(1,k),1) end do call scopy(m,wrk,1,A(1,j),1) else call scopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call scopy(m,A(1,k-1),1,A(1,k),1) end do call scopy(m,wrk,1,A(1,j),1) end if ! update the QR decomposition k = m if (ec == 1) k = n call sqrshc(m,n,k,Q,m,R,m,i,j,wrk) ! check result call sqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,i,j,ec) use iso_fortran_env integer m,n,i,j,ec real(real64) A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external drandg,dqrgen,dcopy,dqrshc,dqrchk integer k ! set up random matrix & vector call drandg(m,n,A,m) ! generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) ! update A if (i < j) then call dcopy(m,A(1,i),1,wrk,1) do k = i,j-1 call dcopy(m,A(1,k+1),1,A(1,k),1) end do call dcopy(m,wrk,1,A(1,j),1) else call dcopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call dcopy(m,A(1,k-1),1,A(1,k),1) end do call dcopy(m,wrk,1,A(1,j),1) end if ! update the QR decomposition k = m if (ec == 1) k = n call dqrshc(m,n,k,Q,m,R,m,i,j,wrk) ! check result call dqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,i,j,ec) use iso_fortran_env integer m,n,i,j,ec complex(real32) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) real(real32) rwrk(m) external crandg,cqrgen,ccopy,cqrshc,cqrchk integer k ! set up random matrix & vector call crandg(m,n,A,m) ! generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) ! update A if (i < j) then call ccopy(m,A(1,i),1,wrk,1) do k = i,j-1 call ccopy(m,A(1,k+1),1,A(1,k),1) end do call ccopy(m,wrk,1,A(1,j),1) else call ccopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call ccopy(m,A(1,k-1),1,A(1,k),1) end do call ccopy(m,wrk,1,A(1,j),1) end if ! update the QR decomposition k = m if (ec == 1) k = n call cqrshc(m,n,k,Q,m,R,m,i,j,wrk,rwrk) ! check result call cqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,i,j,ec) use iso_fortran_env integer m,n,i,j,ec complex(real64) A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) real(real64) rwrk(m) external zrandg,zqrgen,zcopy,zqrshc,zqrchk integer k ! set up random matrix & vector call zrandg(m,n,A,m) ! generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) ! update A if (i < j) then call zcopy(m,A(1,i),1,wrk,1) do k = i,j-1 call zcopy(m,A(1,k+1),1,A(1,k),1) end do call zcopy(m,wrk,1,A(1,j),1) else call zcopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call zcopy(m,A(1,k-1),1,A(1,k),1) end do call zcopy(m,wrk,1,A(1,j),1) end if ! update the QR decomposition k = m if (ec == 1) k = n call zqrshc(m,n,k,Q,m,R,m,i,j,wrk,rwrk) ! check result call zqrchk(m,n,k,A,m,Q,m,R,m) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/test/utils.f90000066400000000000000000000727311522610125300235630ustar00rootroot00000000000000! Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic, Jaroslav Hajek ! Copyright (C) 2026 Martin Köhler ! ! This file is part of qrupdate-ng. ! ! qrupdate is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 3 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this software; see the file COPYING. If not, see ! . ! subroutine srandg(m,n,x,ldx) use iso_fortran_env integer m,n,ldx real(real32) x(ldx,*) external slaruv integer seed(4),j,k common /xrand/ seed do j = 1,n do k = 1,m,128 call slaruv(seed,min(m-k+1,128),x(k,j)) end do end do do j = 1,n do k = 1,m if (.not. (x(k,j) > 0e0 .and. x(k,j) < 1e0)) then stop 'slaruv produced invalid number' end if end do end do end subroutine subroutine drandg(m,n,x,ldx) use iso_fortran_env integer m,n,ldx real(real64) x(ldx,*) external dlaruv integer seed(4),j,k common /xrand/ seed do j = 1,n do k = 1,m,128 call dlaruv(seed,min(m-k+1,128),x(k,j)) end do end do do j = 1,n do k = 1,m if (.not. (x(k,j) > 0d0 .and. x(k,j) < 1d0)) then stop 'dlaruv produced invalid number' end if end do end do end subroutine subroutine crandg(m,n,x,ldx) use iso_fortran_env integer m,n,ldx integer k,l complex(real32) x(ldx,*) external srandg real(real32), allocatable :: xr(:,:) allocate(xr(2*ldx,n)) call srandg(2*m,n,xr,2*ldx) do l = 1, n do k = 1, m x(k,l) = cmplx(xr(2*k-1,l), xr(2*k,l)) end do end do deallocate(xr) end subroutine subroutine zrandg(m,n,x,ldx) use iso_fortran_env integer m,n,ldx complex(real64) x(ldx,*) external drandg integer l,k real(real64), allocatable :: xr(:,:) allocate(xr(2*ldx,n)) call drandg(2*m,n,xr,2*ldx) do l = 1, n do k = 1, m x(k,l) = cmplx(xr(2*k-1,l), xr(2*k,l), kind = 8) end do end do deallocate(xr) end subroutine block data xrandi integer seed(4) common /xrand/ seed data seed /4*1/ end block data subroutine sqrgen(m,n,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,lda,ldq,ldr real(real32) A(lda,n),Q(ldq,m),R(ldr,n) real(real32) work(max(m,n)),tau(min(m,n)) integer info,i,j external slacpy,sgeqrf,sorgqr if (m == 0) return call slacpy('0',m,n,A,lda,R,ldr) call sgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0e0 end do end do call sorgqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine dqrgen(m,n,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,lda,ldq,ldr real(real64) A(lda,n),Q(ldq,m),R(ldr,n) real(real64) work(max(m,n)),tau(min(m,n)) integer info,i,j external dlacpy,dgeqrf,dorgqr if (m == 0) return call dlacpy('0',m,n,A,lda,R,ldr) call dgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0d0 end do end do call dorgqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine cqrgen(m,n,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,lda,ldq,ldr complex(real32) A(lda,n),Q(ldq,m),R(ldr,n) complex(real32) work(max(m,n)),tau(min(m,n)) integer info,i,j external clacpy,cgeqrf,cungqr if (m == 0) return call clacpy('0',m,n,A,lda,R,ldr) call cgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0e0 end do end do call cungqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine zqrgen(m,n,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,lda,ldq,ldr complex(real64) A(lda,n),Q(ldq,m),R(ldr,n) complex(real64) work(max(m,n)),tau(min(m,n)) integer info,i,j external zlacpy,zgeqrf,zungqr if (m == 0) return call zlacpy('0',m,n,A,lda,R,ldr) call zgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0d0 end do end do call zungqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine smdump(name,m,n,A,lda) use iso_fortran_env character(*) name integer m,n,lda real(real32) A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,$) end subroutine subroutine dmdump(name,m,n,A,lda) use iso_fortran_env character(*) name integer m,n,lda real(real64) A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,$) end subroutine subroutine cmdump(name,m,n,A,lda) use iso_fortran_env character(*) name integer m,n,lda complex(real32) A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,SP,F6.3,'i',$) end subroutine subroutine zmdump(name,m,n,A,lda) use iso_fortran_env character(*) name integer m,n,lda complex(real64) A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,SP,F6.3,'i',$) end subroutine character*4 function spftol(rnrm) use iso_fortran_env real(real32) rnrm,slamch external slamch common /stats/ passed,failed integer passed,failed if (rnrm < 5e2*slamch('p')) then spftol = 'PASS' passed = passed + 1 else spftol = 'FAIL' failed = failed + 1 end if end function character*4 function dpftol(rnrm) use iso_fortran_env real(real64) rnrm,dlamch external dlamch common /stats/ passed,failed integer passed,failed if (rnrm < 5d2*dlamch('p')) then dpftol = 'PASS' passed = passed + 1 else dpftol = 'FAIL' failed = failed + 1 end if end function subroutine pstats common /stats/ passed,failed integer passed,failed write(*,1001) write(*,1002) passed,failed write(*,*) if (failed .ne. 0) then stop 1 end if 1001 format(70('-')) 1002 format(1x,'total:',5x,'PASSED',1x,I3,5x,'FAILED',1x,I3) end subroutine subroutine sqrchk(m,n,k,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,k,lda,ldq,ldr real(real32) A(lda,max(n,k)),Q(ldq,k),R(ldr,n) real(real32) rnrm,slange,slansy external sgemm,ssyrk,slange,slansy,spftol character*4 spftol real(real32) wrk(m) integer i ! get residual call sgemm('N','N',m,n,k,-1e0,Q,ldq,R,ldr,1e0,A,lda) ! get frobenius norm rnrm = slange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) ! form Q'*Q - I call ssyrk('U','T',k,m,1e0,Q,ldq,0e0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1e0 end do ! get frobenius norm rnrm = slansy('M','U',k,A,lda,wrk) write(*,1002) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dqrchk(m,n,k,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,k,lda,ldq,ldr real(real64) A(lda,max(n,k)),Q(ldq,k),R(ldr,n) real(real64) rnrm,dlange,dlansy external dgemm,dsyrk,dlange,dlansy,dpftol character*4 dpftol real(real64) wrk(m) integer i ! get residual call dgemm('N','N',m,n,k,-1d0,Q,ldq,R,ldr,1d0,A,lda) ! get frobenius norm rnrm = dlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) ! form Q'*Q - I call dsyrk('U','T',k,m,1d0,Q,ldq,0d0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1d0 end do ! get frobenius norm rnrm = dlansy('M','U',k,A,lda,wrk) write(*,1002) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine cqrchk(m,n,k,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,k,lda,ldq,ldr complex(real32) A(lda,max(n,k)),Q(ldq,k),R(ldr,n) real(real32) rnrm,clange,clanhe external cgemm,cherk,clange,clanhe,spftol character*4 spftol real(real32) wrk(m) integer i ! get residual call cgemm('N','N',m,n,k,-(1e0,0e0),Q,ldq,R,ldr,(1e0,0e0),A,lda) ! get frobenius norm rnrm = clange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) ! form Q'*Q - I call cherk('U','C',k,m,1e0,Q,ldq,0e0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1e0 end do ! get frobenius norm rnrm = clanhe('M','U',k,A,lda,wrk) write(*,1002) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zqrchk(m,n,k,A,lda,Q,ldq,R,ldr) use iso_fortran_env integer m,n,k,lda,ldq,ldr complex(real64) A(lda,max(n,k)),Q(ldq,k),R(ldr,n) real(real64) rnrm,zlange,zlanhe external zgemm,zherk,zlange,zlanhe,dpftol character*4 dpftol real(real64) wrk(m) integer i ! get residual call zgemm('N','N',m,n,k,-(1d0,0d0),Q,ldq,R,ldr,(1d0,0d0),A,lda) ! get frobenius norm rnrm = zlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) ! form Q'*Q - I call zherk('U','C',k,m,1d0,Q,ldq,0d0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1d0 end do ! get frobenius norm rnrm = zlanhe('M','U',k,A,lda,wrk) write(*,1002) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine schgen(n,A,lda,R,ldr) use iso_fortran_env integer n,lda,ldr real(real32) A(lda,n),R(ldr,n) external ssyrk,slacpy,spotrf integer i,j,info call ssyrk('U','T',n,n,1e0,A,lda,0e0,R,ldr) ! augment to ensure strict positivity, zero below diag do i = 1,n R(i,i) = R(i,i) + 1e-3 ! zero below diagonal do j = i+1,n R(j,i) = 0e0 end do end do call slacpy('U',n,n,R,ldr,A,lda) ! symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = A(i,j) end do end do call spotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' end subroutine subroutine dchgen(n,A,lda,R,ldr) use iso_fortran_env integer n,lda,ldr real(real64) A(lda,n),R(ldr,n) external dsyrk,dlacpy,dpotrf integer i,j,info call dsyrk('U','T',n,n,1d0,A,lda,0d0,R,ldr) ! augment to ensure strict positivity do i = 1,n R(i,i) = R(i,i) + 1d-3 ! zero below diagonal do j = i+1,n R(j,i) = 0d0 end do end do call dlacpy('U',n,n,R,ldr,A,lda) ! symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = A(i,j) end do end do call dpotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' end subroutine subroutine cchgen(n,A,lda,R,ldr) use iso_fortran_env use qrupdate_blas integer n,lda,ldr complex(real32) A(lda,n),R(ldr,n) external cherk,clacpy,cpotrf complex(real32) Rii integer i,j,info call cherk('U','C',n,n,1e0,A,lda,0e0,R,ldr) ! augment to ensure strict positivity do i = 1,n ! CHERK is often buggy. We'll recompute the diagonal elements and ! possibly warn about the bug. call qrupdate_cdotc (Rii, n, A(1,i), 1, A(1,i), 1) if (.not. abs (Rii - R(i,i)) < 1e-5 * abs(Rii)) then write (*,1001) write (*,1002) R(i,i), Rii endif ! R(i,i) = Rii + 1e-3 R(i,i) = cmplx(real(Rii)+1e-3,0.0) ! zero below diagonal do j = i+1,n R(j,i) = 0e0 end do end do call clacpy('U',n,n,R,ldr,A,lda) ! symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = conjg(A(i,j)) end do end do call cpotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' 1001 format ('WARNING: Possible bug in BLAS CHERK:') 1002 format ('WARNING: CHERK computed diagonal element (', & &F6.3,F6.3,'), direct computation gives (',F6.3,F6.3,').') end subroutine subroutine zchgen(n,A,lda,R,ldr) use iso_fortran_env use qrupdate_blas integer n,lda,ldr complex(real64) A(lda,n),R(ldr,n) external zherk,zlacpy,zpotrf complex(real64) Rii integer i,j,info call zherk('U','C',n,n,1d0,A,lda,0d0,R,ldr) ! augment to ensure strict positivity do i = 1,n ! ZHERK is often buggy. We'll recompute the diagonal elements and ! possibly warn about the bug. call qrupdate_zdotc (Rii, n, A(1,i), 1, A(1,i), 1) if (.not. abs (Rii - R(i,i)) < 1d-10 * abs(Rii)) then write (*,1001) write (*,1002) R(i,i), Rii endif ! R(i,i) = Rii + 1d-3 R(i,i) = dcmplx(real(Rii)+1D-3,0.0D0) ! zero below diagonal do j = i+1,n R(j,i) = 0d0 end do end do call zlacpy('U',n,n,R,ldr,A,lda) ! symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = conjg(A(i,j)) end do end do call zpotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' 1001 format ('WARNING: Possible bug in BLAS CHERK:') 1002 format ('WARNING: ZHERK computed diagonal element (', & &F6.3,F6.3,'), direct computation gives (',F6.3,F6.3,').') end subroutine subroutine schchk(n,A,lda,R,ldr) use iso_fortran_env integer n,lda,ldr real(real32) A(lda,n),R(ldr,n) real(real32) rnrm,slansy external ssyrk,slansy,spftol character*4 spftol real wrk(n) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0e0 end do end do ! form A - R'*R call ssyrk('U','T',n,n,1e0,R,ldr,-1e0,A,lda) ! get frobenius norm rnrm = slansy('M','U',n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dchchk(n,A,lda,R,ldr) use iso_fortran_env integer n,lda,ldr real(real64) A(lda,n),R(ldr,n) real(real64) rnrm,dlansy external dsyrk,dlansy,dpftol character*4 dpftol double precision wrk(n) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0d0 end do end do ! form A - R'*R call dsyrk('U','T',n,n,1d0,R,ldr,-1d0,A,lda) ! get frobenius norm rnrm = dlansy('M','U',n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine cchchk(n,A,lda,R,ldr) use iso_fortran_env integer n,lda,ldr complex(real32) A(lda,n),R(ldr,n) real(real32) rnrm,clanhe external cherk,clanhe,spftol character*4 spftol real wrk(n) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0e0 end do end do ! form A - R'*R call cherk('U','C',n,n,1e0,R,ldr,-1e0,A,lda) ! get frobenius norm rnrm = clanhe('M','U',n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zchchk(n,A,lda,R,ldr) use iso_fortran_env integer n,lda,ldr complex(real64) A(lda,n),R(ldr,n) real(real64) rnrm,zlanhe external zherk,zlanhe,dpftol character*4 dpftol double precision wrk(n) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0d0 end do end do ! form A - R'*R call zherk('U','C',n,n,1d0,R,ldr,-1d0,A,lda) ! get frobenius norm rnrm = zlanhe('M','U',n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine slugen(m,n,A,lda,L,ldl,R,ldr) use iso_fortran_env integer m,n,lda,ldl,ldr real(real32) A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external sswap,slacpy,sgetrf if (m >= n) then call slacpy('0',m,n,A,lda,L,ldl) call sgetrf(m,n,L,ldl,ipiv,info) call slacpy('U',m,n,L,ldl,R,ldr) else call slacpy('0',m,n,A,lda,R,ldr) call sgetrf(m,n,R,ldr,ipiv,info) call slacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0e0 end do L(i,i) = 1e0 end do ! permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call sswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine dlugen(m,n,A,lda,L,ldl,R,ldr) use iso_fortran_env integer m,n,lda,ldl,ldr real(real64) A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external dswap,dlacpy,dgetrf if (m >= n) then call dlacpy('0',m,n,A,lda,L,ldl) call dgetrf(m,n,L,ldl,ipiv,info) call dlacpy('U',m,n,L,ldl,R,ldr) else call dlacpy('0',m,n,A,lda,R,ldr) call dgetrf(m,n,R,ldr,ipiv,info) call dlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do ! permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call dswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine clugen(m,n,A,lda,L,ldl,R,ldr) use iso_fortran_env integer m,n,lda,ldl,ldr complex(real32) A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external cswap,clacpy,cgetrf if (m >= n) then call clacpy('0',m,n,A,lda,L,ldl) call cgetrf(m,n,L,ldl,ipiv,info) call clacpy('U',m,n,L,ldl,R,ldr) else call clacpy('0',m,n,A,lda,R,ldr) call cgetrf(m,n,R,ldr,ipiv,info) call clacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = cmplx(0.0,0.0) end do L(i,i) = cmplx(1.0,0.0) end do ! permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call cswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine zlugen(m,n,A,lda,L,ldl,R,ldr) use iso_fortran_env integer m,n,lda,ldl,ldr complex(real64) A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external zswap,zlacpy,zgetrf if (m >= n) then call zlacpy('0',m,n,A,lda,L,ldl) call zgetrf(m,n,L,ldl,ipiv,info) call zlacpy('U',m,n,L,ldl,R,ldr) else call zlacpy('0',m,n,A,lda,R,ldr) call zgetrf(m,n,R,ldr,ipiv,info) call zlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do ! permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call zswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine sluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr real A(lda,n),L(ldl,min(m,n)),R(ldr,n) real rnrm,slange external sgemm,slange,spftol character*4 spftol real wrk(1) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do ! form A - L*R call sgemm('N','N',m,n,min(m,n),1e0,L,ldl,R,ldr,-1e0,A,lda) ! get frobenius norm rnrm = slange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr double precision A(lda,n),L(ldl,min(m,n)),R(ldr,n) double precision rnrm,dlange external dgemm,dlange,dpftol character*4 dpftol double precision wrk(1) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do ! form A - L*R call dgemm('N','N',m,n,min(m,n),1d0,L,ldl,R,ldr,-1d0,A,lda) ! get frobenius norm rnrm = dlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine cluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) real rnrm,clange external cgemm,clange,spftol character*4 spftol real wrk(1) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do ! form A - L*R call cgemm('N','N',m,n,min(m,n),(1e0,0e0),L,ldl,R,ldr,(-1e0,0e0), & &A,lda) ! get frobenius norm rnrm = clange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr double complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) double precision rnrm,zlange external zgemm,zlange,dpftol character*4 dpftol double precision wrk(1) integer i,j ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do ! form A - L*R call zgemm('N','N',m,n,min(m,n),(1d0,0d0),L,ldl,R,ldr,(-1d0,0d0), & &A,lda) ! get frobenius norm rnrm = zlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine slupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) real A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external sswap,slacpy,sgetrf if (m >= n) then call slacpy('0',m,n,A,lda,L,ldl) call sgetrf(m,n,L,ldl,ipiv,info) call slacpy('U',m,n,L,ldl,R,ldr) else call slacpy('0',m,n,A,lda,R,ldr) call sgetrf(m,n,R,ldr,ipiv,info) call slacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0e0 end do L(i,i) = 1e0 end do ! generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do end subroutine subroutine dlupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) double precision A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external dswap,dlacpy,dgetrf if (m >= n) then call dlacpy('0',m,n,A,lda,L,ldl) call dgetrf(m,n,L,ldl,ipiv,info) call dlacpy('U',m,n,L,ldl,R,ldr) else call dlacpy('0',m,n,A,lda,R,ldr) call dgetrf(m,n,R,ldr,ipiv,info) call dlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do ! generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0d0 end do end do end subroutine subroutine clupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external cswap,clacpy,cgetrf if (m >= n) then call clacpy('0',m,n,A,lda,L,ldl) call cgetrf(m,n,L,ldl,ipiv,info) call clacpy('U',m,n,L,ldl,R,ldr) else call clacpy('0',m,n,A,lda,R,ldr) call cgetrf(m,n,R,ldr,ipiv,info) call clacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0e0 end do L(i,i) = 1e0 end do ! generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do end subroutine subroutine zlupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) double complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external zswap,zlacpy,zgetrf if (m >= n) then call zlacpy('0',m,n,A,lda,L,ldl) call zgetrf(m,n,L,ldl,ipiv,info) call zlacpy('U',m,n,L,ldl,R,ldr) else call zlacpy('0',m,n,A,lda,R,ldr) call zgetrf(m,n,R,ldr,ipiv,info) call zlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do ! generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do ! zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0d0 end do end do end subroutine ! converts a linear permutation into LAPACK ipiv-style form subroutine p2ipiv(n,p) integer n,p(n) integer q(n),i,j,k do i = 1,n q(p(i)) = i end do do i = 1,n j = p(i) k = q(i) if (j /= i) then p(k) = j q(j) = k p(i) = j end if end do end subroutine subroutine slupchk(m,n,A,lda,L,ldl,R,ldr,p) use iso_fortran_env integer m,n,lda,ldl,ldr,p(m) real(real32) A(lda,n),L(ldl,min(m,n)),R(ldr,n) real(real32) rnrm,slange external p2ipiv,sswap,sgemm,slange,spftol character*4 spftol real wrk(1) integer i,j ! convert p into successive swaps call p2ipiv(m,p) ! form A - L*R do i = 1,m j = p(i) if (i /= j) then call sswap(n,A(i,1),lda,A(j,1),lda) end if end do call sgemm('N','N',m,n,min(m,n),1e0,L,ldl,R,ldr,-1e0,A,lda) ! get frobenius norm rnrm = slange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dlupchk(m,n,A,lda,L,ldl,R,ldr,p) use iso_fortran_env integer m,n,lda,ldl,ldr,p(m) real(real64) A(lda,n),L(ldl,min(m,n)),R(ldr,n) real(real64) rnrm,dlange external p2ipiv,dswap,dgemm,dlange,dpftol character*4 dpftol double precision wrk(1) integer i,j ! convert p into successive swaps call p2ipiv(m,p) ! form A - L*R do i = 1,m j = p(i) if (i /= j) then call dswap(n,A(i,1),lda,A(j,1),lda) end if end do call dgemm('N','N',m,n,min(m,n),1d0,L,ldl,R,ldr,-1d0,A,lda) ! get frobenius norm rnrm = dlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine clupchk(m,n,A,lda,L,ldl,R,ldr,p) use iso_fortran_env integer m,n,lda,ldl,ldr,p(m) complex(real32) A(lda,n),L(ldl,min(m,n)),R(ldr,n) real(real32) rnrm,clange external p2ipiv,cswap,cgemm,clange,spftol character*4 spftol real wrk(1) integer i,j ! convert p into successive swaps call p2ipiv(m,p) ! form A - L*R do i = 1,m j = p(i) if (i /= j) then call cswap(n,A(i,1),lda,A(j,1),lda) end if end do call cgemm('N','N',m,n,min(m,n),(1e0,0e0),L,ldl,R,ldr,(-1e0,0e0), & &A,lda) ! get frobenius norm rnrm = clange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zlupchk(m,n,A,lda,L,ldl,R,ldr,p) use iso_fortran_env integer m,n,lda,ldl,ldr,p(m) complex(real64) A(lda,n),L(ldl,min(m,n)),R(ldr,n) real(real64) rnrm,zlange external p2ipiv,zswap,zgemm,zlange,dpftol character*4 dpftol double precision wrk(1) integer i,j ! convert p into successive swaps call p2ipiv(m,p) ! form A - L*R do i = 1,m j = p(i) if (i /= j) then call zswap(n,A(i,1),lda,A(j,1),lda) end if end do call zgemm('N','N',m,n,min(m,n),(1d0,0d0),L,ldl,R,ldr,(-1d0,0d0), & &A,lda) ! get frobenius norm rnrm = zlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) END qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/000077500000000000000000000000001522610125300222525ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/ci/000077500000000000000000000000001522610125300226455ustar00rootroot00000000000000qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/ci/cross-win32.sh000066400000000000000000000005021522610125300252670ustar00rootroot00000000000000#!/bin/bash export WINEARCH=win32 export WINEPREFIX=$(mktemp -d -p "$(pwd)") set -x (cd tools/; bash install-lapack-mingw-i686.sh) cmake -S . -B build.win32 -DCMAKE_TOOLCHAIN_FILE=$(pwd)/cmake/mingw-w32-i686.cmake -DBUILD_SHARED_LIBS=ON --fresh make -C build.win32 all (cd build.win32; ctest -V ) rm -rf "${WINEPREFIX}" qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/ci/cross-win64.sh000066400000000000000000000004761522610125300253060ustar00rootroot00000000000000#!/bin/bash export WINEARCH=win64 export WINEPREFIX=$(mktemp -d -p "$(pwd)") set -x (cd tools/; bash install-lapack-mingw-x86_64.sh) cmake -S . -B build.win64 -DCMAKE_TOOLCHAIN_FILE=$(pwd)/cmake/mingw-w64-x86_64.cmake -DBUILD_SHARED_LIBS=ON make -C build.win64 all (cd build.win64; ctest -V ) rm -rf "${WINEPREFIX}" qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/install-lapack-mingw-i686.sh000066400000000000000000000010561522610125300273200ustar00rootroot00000000000000#!/bin/bash set -x export LAPACK_VERSION=3.12.1 [ -d build-lapack-win32 ] && rm -rf build-lapack-win32 [ -e v${LAPACK_VERSION}.tar.gz ] || wget -c https://github.com/Reference-LAPACK/lapack/archive/refs/tags/v${LAPACK_VERSION}.tar.gz tar xf v${LAPACK_VERSION}.tar.gz cmake -S lapack-${LAPACK_VERSION} -B build-lapack-win32 \ -DCMAKE_TOOLCHAIN_FILE=$(pwd)/../cmake/mingw-w32-i686.cmake \ -DBUILD_SHARED_LIBS=ON \ -DCMAKE_INSTALL_PREFIX=`dirname $(realpath $0)`/i686-w64-mingw32 make -C build-lapack-win32 -j 4 make -C build-lapack-win32 install qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/install-lapack-mingw-x86_64.sh000066400000000000000000000010621522610125300275570ustar00rootroot00000000000000#!/bin/bash export LAPACK_VERSION=3.12.1 set -x [ -d build-lapack-win64 ] && rm -rf build-lapack-win64 [ -e v${LAPACK_VERSION}.tar.gz ] || wget -c https://github.com/Reference-LAPACK/lapack/archive/refs/tags/v${LAPACK_VERSION}.tar.gz tar xf v${LAPACK_VERSION}.tar.gz cmake -S lapack-${LAPACK_VERSION} -B build-lapack-win64 \ -DCMAKE_TOOLCHAIN_FILE=$(pwd)/../cmake/mingw-w64-x86_64.cmake \ -DBUILD_SHARED_LIBS=ON \ -DCMAKE_INSTALL_PREFIX=`dirname $(realpath $0)`/x86_64-w64-mingw32 make -C build-lapack-win64 -j 4 make -C build-lapack-win64 install qrupdate-ng-v1.2.0-328f929492008e742619a4b1fc1643253aa1712c/tools/new-version.sh000077500000000000000000000010021522610125300250560ustar00rootroot00000000000000#!/usr/bin/env sh if [ $# -ne 1 ]; then echo "usage: $0 version" exit 1 fi NEWV=$1 D=$(date +'%Y-%m-%d') sed -i -e "s/VERSION \([[:digit:]]\+[\.]\?\)\{3\} /VERSION ${NEWV} /g" CMakeLists.txt sed -i -e "s/version: \([[:digit:]]\+[\.]\?\)\{3\}/version: ${NEWV}/g" CODE sed -i -e "s/release-date: .*$/release-date: ${D}/g" CODE sed -i -e "s/Version: \([[:digit:]]\+[\.]\?\)\{3\}.*$/Version: ${NEWV} (${D})/g" README.md sed -i -e "s/version = \"\([[:digit:]]\+[\.]\?\)\{3\}\"/version = \"${NEWV}\"/g" fpm.toml